]> Dogcows Code - chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate/blob - lib/DBIx/Class/ResultSet/RecursiveUpdate.pm
docs fix
[chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate] / lib / DBIx / Class / ResultSet / RecursiveUpdate.pm
1 use strict;
2 use warnings;
3 package DBIx::Class::ResultSet::RecursiveUpdate;
4
5 use version; our $VERSION = qv('0.006');
6
7 use base qw(DBIx::Class::ResultSet);
8
9 sub recursive_update {
10 my ( $self, $updates, $fixed_fields ) = @_;
11 return DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update(
12 resultset => $self,
13 updates => $updates,
14 fixed_fields => $fixed_fields
15 );
16 }
17
18 package DBIx::Class::ResultSet::RecursiveUpdate::Functions;
19 use Carp;
20 use Scalar::Util qw( blessed );
21
22
23 sub recursive_update {
24 my %params = @_;
25 my ( $self, $updates, $fixed_fields, $object ) = @params{ qw/resultset updates fixed_fields object/ };
26 # warn 'entering: ' . $self->result_source->from();
27 carp 'fixed fields needs to be an array ref' if $fixed_fields && ref($fixed_fields) ne 'ARRAY';
28 my %fixed_fields;
29 %fixed_fields = map { $_ => 1 } @$fixed_fields if $fixed_fields;
30 if ( blessed($updates) && $updates->isa('DBIx::Class::Row') ) {
31 return $updates;
32 }
33 # warn Dumper( $updates ); use Data::Dumper;
34 # direct column accessors
35 my %columns;
36
37 # relations that that should be done before the row is inserted into the database
38 # like belongs_to
39 my %pre_updates;
40
41 # relations that that should be done after the row is inserted into the database
42 # like has_many and might_have
43 my %post_updates;
44 my %other_methods;
45 my %columns_by_accessor = _get_columns_by_accessor( $self );
46 for my $name ( keys %$updates ) {
47 my $source = $self->result_source;
48 if( $name eq 'id'
49 # && scalar @{$source->primary_columns} == 1
50 && !$source->has_column( 'id' )
51 ){
52 my @ids = ( $updates->{id} );
53 if( ref $updates->{id} ){
54 @ids = @{ $updates->{id} };
55 }
56 my $i = 0;
57 for my $key ( $source->primary_columns ){
58 $columns{ $key } = $ids[ $i++ ];
59 }
60 next;
61 }
62 if ( $columns_by_accessor{$name}
63 && !( $source->has_relationship($name) && ref( $updates->{$name} ) )
64 )
65 {
66 $columns{$name} = $updates->{$name};
67 next;
68 }
69 if( !( $source->has_relationship($name) ) ){
70 $other_methods{$name} = $updates->{$name};
71 next;
72 }
73 my $info = $source->relationship_info($name);
74 if (
75 _master_relation_cond(
76 $source, $info->{cond}, _get_pk_for_related( $self, $name)
77 )
78 )
79 {
80 $pre_updates{$name} = $updates->{$name};
81 }
82 else {
83 $post_updates{$name} = $updates->{$name};
84 }
85 }
86 # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
87
88 my @missing =
89 grep { !exists $columns{$_} && !exists $fixed_fields{$_} } $self->result_source->primary_columns;
90 if ( !$object && !scalar @missing ) {
91 $object = $self->find( \%columns, { key => 'primary' } );
92 }
93 $object ||= $self->new( {} );
94 # first update columns and other accessors - so that later related records can be found
95 for my $name ( keys %columns ) {
96 $object->$name( $columns{$name} );
97 }
98 for my $name ( keys %other_methods) {
99 $object->$name( $updates->{$name} ) if $object->can( $name );
100 }
101 for my $name ( keys %pre_updates ) {
102 my $info = $object->result_source->relationship_info($name);
103 _update_relation( $self, $name, $updates, $object, $info );
104 }
105 # $self->_delete_empty_auto_increment($object);
106 # don't allow insert to recurse to related objects - we do the recursion ourselves
107 # $object->{_rel_in_storage} = 1;
108 $object->update_or_insert;
109
110 # updating many_to_many
111 for my $name ( keys %$updates ) {
112 next if exists $columns{$name};
113 my $value = $updates->{$name};
114
115 if ( is_m2m( $self, $name) ) {
116 my ($pk) = _get_pk_for_related( $self, $name);
117 my @rows;
118 my $result_source = $object->$name->result_source;
119 my @updates;
120 if( ! defined $value ){
121 next;
122 }
123 elsif( ref $value ){
124 @updates = @{ $value };
125 }
126 else{
127 @updates = ( $value );
128 }
129 for my $elem ( @updates ) {
130 if ( ref $elem ) {
131 push @rows, $result_source->resultset->find($elem);
132 }
133 else {
134 push @rows,
135 $result_source->resultset->find( { $pk => $elem } );
136 }
137 }
138 my $set_meth = 'set_' . $name;
139 $object->$set_meth( \@rows );
140 }
141 }
142 for my $name ( keys %post_updates ) {
143 my $info = $object->result_source->relationship_info($name);
144 _update_relation( $self, $name, $updates, $object, $info );
145 }
146 return $object;
147 }
148
149 sub _get_columns_by_accessor {
150 my $self = shift;
151 my $source = $self->result_source;
152 my %columns;
153 for my $name ( $source->columns ) {
154 my $info = $source->column_info($name);
155 $info->{name} = $name;
156 $columns{ $info->{accessor} || $name } = $info;
157 }
158 return %columns;
159 }
160
161 sub _update_relation {
162 my ( $self, $name, $updates, $object, $info ) = @_;
163 my $related_result =
164 $self->related_resultset($name)->result_source->resultset;
165 my $resolved =
166 $self->result_source->resolve_condition( $info->{cond}, $name, $object );
167
168 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
169 $resolved = undef
170 if defined $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION && $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION == $resolved;
171 if ( ref $updates->{$name} eq 'ARRAY' ) {
172 for my $sub_updates ( @{ $updates->{$name} } ) {
173 $sub_updates = { %$sub_updates, %$resolved } if $resolved && ref( $sub_updates ) eq 'HASH';
174 my $sub_object =
175 recursive_update( resultset => $related_result, updates => $sub_updates );
176 }
177 }
178 else {
179 my $sub_updates = $updates->{$name};
180 my $sub_object;
181 if( ref $sub_updates ){
182 $sub_updates = { %$sub_updates, %$resolved } if $resolved && ref( $sub_updates ) eq 'HASH';
183 # for might_have relationship
184 if( $info->{attrs}{accessor} eq 'single' && defined $object->$name ){
185 $sub_object = recursive_update(
186 resultset => $related_result,
187 updates => $sub_updates,
188 object => $object->$name
189 );
190 }
191 else{
192 $sub_object =
193 recursive_update( resultset => $related_result, updates => $sub_updates );
194 }
195 }
196 elsif( ! ref $sub_updates ){
197 $sub_object = $related_result->find( $sub_updates );
198 }
199 $object->set_from_related( $name, $sub_object );
200 }
201 }
202
203 sub is_m2m {
204 my ( $self, $relation ) = @_;
205 my $rclass = $self->result_class;
206
207 # DBIx::Class::IntrospectableM2M
208 if ( $rclass->can('_m2m_metadata') ) {
209 return $rclass->_m2m_metadata->{$relation};
210 }
211 my $object = $self->new( {} );
212 if ( $object->can($relation)
213 and !$self->result_source->has_relationship($relation)
214 and $object->can( 'set_' . $relation ) )
215 {
216 return 1;
217 }
218 return;
219 }
220
221 sub get_m2m_source {
222 my ( $self, $relation ) = @_;
223 my $rclass = $self->result_class;
224
225 # DBIx::Class::IntrospectableM2M
226 if ( $rclass->can('_m2m_metadata') ) {
227 return $self->result_source->related_source(
228 $rclass->_m2m_metadata->{$relation}{relation} )
229 ->related_source(
230 $rclass->_m2m_metadata->{$relation}{foreign_relation} );
231 }
232 my $object = $self->new( {} );
233 my $r = $object->$relation;
234 return $r->result_source;
235 }
236
237 sub _delete_empty_auto_increment {
238 my ( $self, $object ) = @_;
239 for my $col ( keys %{ $object->{_column_data} } ) {
240 if (
241 $object->result_source->column_info($col)->{is_auto_increment}
242 and ( !defined $object->{_column_data}{$col}
243 or $object->{_column_data}{$col} eq '' )
244 )
245 {
246 delete $object->{_column_data}{$col};
247 }
248 }
249 }
250
251 sub _get_pk_for_related {
252 my ( $self, $relation ) = @_;
253 my $result_source;
254 if ( $self->result_source->has_relationship($relation) ) {
255 $result_source = $self->result_source->related_source($relation);
256 }
257
258 # many to many case
259 if ( is_m2m($self, $relation) ) {
260 $result_source = get_m2m_source($self, $relation);
261 }
262 return $result_source->primary_columns;
263 }
264
265 sub _master_relation_cond {
266 my ( $source, $cond, @foreign_ids ) = @_;
267 my $foreign_ids_re = join '|', @foreign_ids;
268 if ( ref $cond eq 'HASH' ) {
269 for my $f_key ( keys %{$cond} ) {
270
271 # might_have is not master
272 my $col = $cond->{$f_key};
273 $col =~ s/self\.//;
274 if ( $source->column_info($col)->{is_auto_increment} ) {
275 return 0;
276 }
277 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
278 return 1;
279 }
280 }
281 }
282 elsif ( ref $cond eq 'ARRAY' ) {
283 for my $new_cond (@$cond) {
284 return 1
285 if _master_relation_cond( $source, $new_cond, @foreign_ids );
286 }
287 }
288 return;
289 }
290
291 1; # Magic true value required at end of module
292 __END__
293
294 =head1 NAME
295
296 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
297
298
299 =head1 VERSION
300
301 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.006
302
303
304 =head1 SYNOPSIS
305
306 The functional interface:
307
308 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
309 resultset => $schema->resultset( 'Dvd' ),
310 updates => {
311 id => 1,
312 owned_dvds => [
313 {
314 title => 'One Flew Over the Cuckoo's Nest'
315 }
316 ]
317 }
318 });
319
320
321 As ResultSet subclass:
322
323 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
324
325 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
326
327 Then:
328
329 my $user = $user_rs->recursive_update( {
330 id => 1,
331 owned_dvds => [
332 {
333 title => 'One Flew Over the Cuckoo's Nest'
334 }
335 ]
336 }
337 );
338
339
340 =head1 DESCRIPTION
341 This is still experimental. I've added a functional interface so that it can be used
342 in Form Processors and not require modification of the model.
343
344 You can feed the ->create method with a recursive datastructure and have the related records
345 created. Unfortunately you cannot do a similar thing with update_or_create - this module
346 tries to fill that void.
347
348 It is a base class for ResultSets providing just one method: recursive_update
349 which works just like update_or_create but can recursively update or create
350 data objects composed of multiple rows. All rows need to be identified by primary keys
351 - so you need to provide them in the update structure (unless they can be deduced from
352 the parent row - for example when you have a belongs_to relationship).
353 If not all colums comprising the primary key are specified - then a new row will be created,
354 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
355 primary keys).
356
357
358 If the resultset itself stores an assignement for the primary key,
359 like in the case of:
360
361 my $restricted_rs = $user_rs->search( { id => 1 } );
362
363 then you need to inform recursive_update about additional predicate with a second argument:
364
365 my $user = $restricted_rs->recursive_update( {
366 owned_dvds => [
367 {
368 title => 'One Flew Over the Cuckoo's Nest'
369 }
370 ]
371 },
372 [ 'id' ]
373 );
374
375 This will work with a new DBIC release.
376
377 For a many_to_many (pseudo) relation you can supply a list of primary keys
378 from the other table - and it will link the record at hand to those and
379 only those records identified by them. This is convenient for handling web
380 forms with check boxes (or a SELECT box with multiple choice) that let you
381 update such (pseudo) relations.
382
383 For a description how to set up base classes for ResultSets see load_namespaces
384 in DBIx::Class::Schema.
385
386 =head1 DESIGN CHOICES
387
388 =head2 Treatment of many to many pseudo relations
389
390 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
391 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
392 if($object->can($name) and
393 !$object->result_source->has_relationship($name) and
394 $object->can( 'set_' . $name )
395 )
396
397 then $name must be a many to many pseudo relation. And that in a
398 similarly ugly was I find out what is the ResultSource of objects from
399 that many to many pseudo relation.
400
401
402 =head1 INTERFACE
403
404 =head1 METHODS
405
406 =head2 recursive_update
407
408 The method that does the work here.
409
410 =head2 is_m2m
411
412 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
413 (pseudo) relation on $self.
414
415 =head2 get_m2m_source
416
417 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
418 to many (pseudo) relation 'name' from $self.
419
420
421 =head1 DIAGNOSTICS
422
423
424 =head1 CONFIGURATION AND ENVIRONMENT
425
426 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
427
428 =head1 DEPENDENCIES
429
430 DBIx::Class
431
432 =head1 INCOMPATIBILITIES
433
434 =for author to fill in:
435
436 None reported.
437
438
439 =head1 BUGS AND LIMITATIONS
440
441 =for author to fill in:
442
443 No bugs have been reported.
444
445 Please report any bugs or feature requests to
446 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
447 L<http://rt.cpan.org>.
448
449
450 =head1 AUTHOR
451
452 Zbigniew Lukasiak C<< <zby@cpan.org> >>
453 Influenced by code by Pedro Melo.
454
455 =head1 LICENCE AND COPYRIGHT
456
457 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
458
459 This module is free software; you can redistribute it and/or
460 modify it under the same terms as Perl itself. See L<perlartistic>.
461
462
463 =head1 DISCLAIMER OF WARRANTY
464
465 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
466 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
467 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
468 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
469 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
470 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
471 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
472 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
473 NECESSARY SERVICING, REPAIR, OR CORRECTION.
474
475 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
476 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
477 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
478 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
479 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
480 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
481 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
482 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
483 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
484 SUCH DAMAGES.
This page took 0.074185 seconds and 4 git commands to generate.