1438959cd5c237c87addab57bea33d51b43887c5
[chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate] / lib / DBIx / Class / ResultSet / RecursiveUpdate.pm
1 use strict;
2 use warnings;
3
4 package DBIx::Class::ResultSet::RecursiveUpdate;
5
6 our $VERSION = '0.013';
7
8 use base qw(DBIx::Class::ResultSet);
9
10 sub recursive_update {
11 my ( $self, $updates, $fixed_fields ) = @_;
12 return
13 DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update(
14 resultset => $self,
15 updates => $updates,
16 fixed_fields => $fixed_fields
17 );
18 }
19
20 package DBIx::Class::ResultSet::RecursiveUpdate::Functions;
21 use Carp;
22 use Scalar::Util qw( blessed );
23
24 sub recursive_update {
25 my %params = @_;
26 my ( $self, $updates, $fixed_fields, $object, $resolved,
27 $if_not_submitted )
28 = @params{
29 qw/resultset updates fixed_fields object resolved if_not_submitted/};
30 $resolved ||= {};
31
32 # warn 'entering: ' . $self->result_source->from();
33 carp 'fixed fields needs to be an array ref'
34 if $fixed_fields && ref($fixed_fields) ne 'ARRAY';
35 my %fixed_fields;
36 %fixed_fields = map { $_ => 1 } @$fixed_fields if $fixed_fields;
37 if ( blessed($updates) && $updates->isa('DBIx::Class::Row') ) {
38 return $updates;
39 }
40 if ( $updates->{id} ) {
41 $object = $self->find( $updates->{id}, { key => 'primary' } );
42 }
43 my @missing =
44 grep { !exists $updates->{$_} && !exists $fixed_fields{$_} }
45 $self->result_source->primary_columns;
46 if ( !$object && !scalar @missing ) {
47
48 # warn 'finding by: ' . Dumper( $updates ); use Data::Dumper;
49 $object = $self->find( $updates, { key => 'primary' } );
50 }
51 $updates = { %$updates, %$resolved };
52 @missing =
53 grep { !exists $resolved->{$_} } @missing;
54 if ( !$object && !scalar @missing ) {
55
56 # warn 'finding by +resolved: ' . Dumper( $updates ); use Data::Dumper;
57 $object = $self->find( $updates, { key => 'primary' } );
58 }
59 $object ||= $self->new( {} );
60
61 # warn Dumper( $updates ); use Data::Dumper;
62 # direct column accessors
63 my %columns;
64
65 # relations that that should be done before the row is inserted into the
66 # database like belongs_to
67 my %pre_updates;
68
69 # relations that that should be done after the row is inserted into the
70 # database like has_many, might_have and has_one
71 my %post_updates;
72 my %other_methods;
73 my %columns_by_accessor = _get_columns_by_accessor($self);
74
75 # warn 'resolved: ' . Dumper( $resolved );
76 # warn 'updates: ' . Dumper( $updates ); use Data::Dumper;
77 # warn 'columns: ' . Dumper( \%columns_by_accessor );
78 for my $name ( keys %$updates ) {
79 my $source = $self->result_source;
80 if ( $columns_by_accessor{$name}
81 && !( $source->has_relationship($name)
82 && ref( $updates->{$name} ) ) )
83 {
84 $columns{$name} = $updates->{$name};
85 next;
86 }
87 if ( !( $source->has_relationship($name) ) ) {
88 $other_methods{$name} = $updates->{$name};
89 next;
90 }
91 my $info = $source->relationship_info($name);
92 if (_master_relation_cond(
93 $source, $info->{cond},
94 _get_pk_for_related( $self, $name )
95 )
96 )
97 {
98 $pre_updates{$name} = $updates->{$name};
99 }
100 else {
101 $post_updates{$name} = $updates->{$name};
102 }
103 }
104
105 # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
106
107 # first update columns and other accessors
108 # so that later related records can be found
109 for my $name ( keys %columns ) {
110 $object->$name( $columns{$name} );
111 }
112 for my $name ( keys %other_methods ) {
113 $object->$name( $updates->{$name} ) if $object->can($name);
114 }
115 for my $name ( keys %pre_updates ) {
116 my $info = $object->result_source->relationship_info($name);
117 _update_relation( $self, $name, $updates, $object, $info,
118 $if_not_submitted );
119 }
120
121 # $self->_delete_empty_auto_increment($object);
122 # don't allow insert to recurse to related objects
123 # do the recursion ourselves
124 # $object->{_rel_in_storage} = 1;
125 $object->update_or_insert if $object->is_changed;
126
127 # updating many_to_many
128 for my $name ( keys %$updates ) {
129 next if exists $columns{$name};
130 my $value = $updates->{$name};
131
132 if ( is_m2m( $self, $name ) ) {
133 my ($pk) = _get_pk_for_related( $self, $name );
134 my @rows;
135 my $result_source = $object->$name->result_source;
136 my @updates;
137 if ( !defined $value ) {
138 next;
139 }
140 elsif ( ref $value ) {
141 @updates = @{$value};
142 }
143 else {
144 @updates = ($value);
145 }
146 for my $elem (@updates) {
147 if ( ref $elem ) {
148 push @rows,
149 recursive_update(
150 resultset => $result_source->resultset,
151 updates => $elem
152 );
153 }
154 else {
155 push @rows,
156 $result_source->resultset->find( { $pk => $elem } );
157 }
158 }
159 my $set_meth = 'set_' . $name;
160 $object->$set_meth( \@rows );
161 }
162 }
163 for my $name ( keys %post_updates ) {
164 my $info = $object->result_source->relationship_info($name);
165 _update_relation( $self, $name, $updates, $object, $info,
166 $if_not_submitted );
167 }
168 return $object;
169 }
170
171 # returns DBIx::Class::ResultSource::column_info as a hash indexed by column accessor || name
172 sub _get_columns_by_accessor {
173 my $self = shift;
174 my $source = $self->result_source;
175 my %columns;
176 for my $name ( $source->columns ) {
177 my $info = $source->column_info($name);
178 $info->{name} = $name;
179 $columns{ $info->{accessor} || $name } = $info;
180 }
181 return %columns;
182 }
183
184 sub _update_relation {
185 my ( $self, $name, $updates, $object, $info, $if_not_submitted ) = @_;
186 my $related_result =
187 $self->related_resultset($name)->result_source->resultset;
188 my $resolved;
189 if ( $self->result_source->can('_resolve_condition') ) {
190 $resolved =
191 $self->result_source->_resolve_condition( $info->{cond}, $name,
192 $object );
193 }
194 else {
195 $resolved =
196 $self->result_source->resolve_condition( $info->{cond}, $name,
197 $object );
198 }
199
200 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
201 $resolved = {}
202 if defined $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
203 && $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
204 == $resolved;
205 if ( ref $updates->{$name} eq 'ARRAY' ) {
206 my @updated_ids;
207 for my $sub_updates ( @{ $updates->{$name} } ) {
208 my $sub_object = recursive_update(
209 resultset => $related_result,
210 updates => $sub_updates,
211 resolved => $resolved
212 );
213 push @updated_ids, $sub_object->id;
214 }
215 my @related_pks = $related_result->result_source->primary_columns;
216 if ( defined $if_not_submitted && $if_not_submitted eq 'delete' ) {
217
218 # only handles related result classes with single primary keys
219 if ( 1 == scalar @related_pks ) {
220 $object->$name->search(
221 { $related_pks[0] => { -not_in => \@updated_ids } } )
222 ->delete;
223 }
224 }
225 elsif ( defined $if_not_submitted
226 && $if_not_submitted eq 'set_to_null' )
227 {
228
229 # only handles related result classes with single primary keys
230 if ( 1 == scalar @related_pks ) {
231 my @fk = keys %$resolved;
232 $object->$name->search(
233 { $related_pks[0] => { -not_in => \@updated_ids } } )
234 ->update( { $fk[0] => undef } );
235 }
236 }
237 }
238 else {
239 my $sub_updates = $updates->{$name};
240 my $sub_object;
241 if ( ref $sub_updates ) {
242
243 # for might_have relationship
244 if ( $info->{attrs}{accessor} eq 'single'
245 && defined $object->$name )
246 {
247 $sub_object = recursive_update(
248 resultset => $related_result,
249 updates => $sub_updates,
250 object => $object->$name
251 );
252 }
253 else {
254 $sub_object = recursive_update(
255 resultset => $related_result,
256 updates => $sub_updates,
257 resolved => $resolved
258 );
259 }
260 }
261 elsif ( !ref $sub_updates ) {
262 $sub_object = $related_result->find($sub_updates)
263 unless (
264 !$sub_updates
265 && ( exists $info->{attrs}{join_type}
266 && $info->{attrs}{join_type} eq 'LEFT' )
267 );
268 }
269 $object->set_from_related( $name, $sub_object )
270 unless (
271 !$sub_object
272 && !$sub_updates
273 && ( exists $info->{attrs}{join_type}
274 && $info->{attrs}{join_type} eq 'LEFT' )
275 );
276 }
277 }
278
279 sub is_m2m {
280 my ( $self, $relation ) = @_;
281 my $rclass = $self->result_class;
282
283 # DBIx::Class::IntrospectableM2M
284 if ( $rclass->can('_m2m_metadata') ) {
285 return $rclass->_m2m_metadata->{$relation};
286 }
287 my $object = $self->new( {} );
288 if ( $object->can($relation)
289 and !$self->result_source->has_relationship($relation)
290 and $object->can( 'set_' . $relation ) )
291 {
292 return 1;
293 }
294 return;
295 }
296
297 sub get_m2m_source {
298 my ( $self, $relation ) = @_;
299 my $rclass = $self->result_class;
300
301 # DBIx::Class::IntrospectableM2M
302 if ( $rclass->can('_m2m_metadata') ) {
303 return $self->result_source->related_source(
304 $rclass->_m2m_metadata->{$relation}{relation} )
305 ->related_source(
306 $rclass->_m2m_metadata->{$relation}{foreign_relation} );
307 }
308 my $object = $self->new( {} );
309 my $r = $object->$relation;
310 return $r->result_source;
311 }
312
313 sub _delete_empty_auto_increment {
314 my ( $self, $object ) = @_;
315 for my $col ( keys %{ $object->{_column_data} } ) {
316 if ($object->result_source->column_info($col)->{is_auto_increment}
317 and ( !defined $object->{_column_data}{$col}
318 or $object->{_column_data}{$col} eq '' )
319 )
320 {
321 delete $object->{_column_data}{$col};
322 }
323 }
324 }
325
326 sub _get_pk_for_related {
327 my ( $self, $relation ) = @_;
328 my $result_source;
329 if ( $self->result_source->has_relationship($relation) ) {
330 $result_source = $self->result_source->related_source($relation);
331 }
332
333 # many to many case
334 if ( is_m2m( $self, $relation ) ) {
335 $result_source = get_m2m_source( $self, $relation );
336 }
337 return $result_source->primary_columns;
338 }
339
340 # This function determines wheter a relationship should be done before or
341 # after the row is inserted into the database
342 # relationships before: belongs_to
343 # relationships after: has_many, might_have and has_one
344 sub _master_relation_cond {
345 my ( $source, $cond, @foreign_ids ) = @_;
346 my $foreign_ids_re = join '|', @foreign_ids;
347 if ( ref $cond eq 'HASH' ) {
348 for my $f_key ( keys %{$cond} ) {
349
350 # might_have is not master
351 my $col = $cond->{$f_key};
352 $col =~ s/self\.//;
353 if ( $source->column_info($col)->{is_auto_increment} ) {
354 return 0;
355 }
356 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
357 return 1;
358 }
359 }
360 }
361 elsif ( ref $cond eq 'ARRAY' ) {
362 for my $new_cond (@$cond) {
363 return _master_relation_cond( $source, $new_cond, @foreign_ids );
364 }
365 }
366 return;
367 }
368
369 1; # Magic true value required at end of module
370 __END__
371
372 =head1 NAME
373
374 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
375
376 =head1 SYNOPSIS
377
378 The functional interface:
379
380 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
381 resultset => $schema->resultset( 'Dvd' ),
382 updates => {
383 id => 1,
384 owned_dvds => [
385 {
386 title => 'One Flew Over the Cuckoo's Nest'
387 }
388 ]
389 }
390 });
391
392
393 As ResultSet subclass:
394
395 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
396
397 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
398
399 Then:
400
401 my $user = $user_rs->recursive_update( {
402 id => 1,
403 owned_dvds => [
404 {
405 title => 'One Flew Over the Cuckoo's Nest'
406 }
407 ]
408 }
409 );
410
411
412 =head1 DESCRIPTION
413
414 This is still experimental. I've added a functional interface so that it can be used
415 in Form Processors and not require modification of the model.
416
417 You can feed the ->create method with a recursive datastructure and have the related records
418 created. Unfortunately you cannot do a similar thing with update_or_create - this module
419 tries to fill that void.
420
421 It is a base class for ResultSets providing just one method: recursive_update
422 which works just like update_or_create but can recursively update or create
423 data objects composed of multiple rows. All rows need to be identified by primary keys
424 - so you need to provide them in the update structure (unless they can be deduced from
425 the parent row - for example when you have a belongs_to relationship).
426 If not all colums comprising the primary key are specified - then a new row will be created,
427 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
428 primary keys).
429
430
431 If the resultset itself stores an assignement for the primary key,
432 like in the case of:
433
434 my $restricted_rs = $user_rs->search( { id => 1 } );
435
436 then you need to inform recursive_update about additional predicate with a second argument:
437
438 my $user = $restricted_rs->recursive_update( {
439 owned_dvds => [
440 {
441 title => 'One Flew Over the Cuckoo's Nest'
442 }
443 ]
444 },
445 [ 'id' ]
446 );
447
448 This will work with a new DBIC release.
449
450 For a many_to_many (pseudo) relation you can supply a list of primary keys
451 from the other table - and it will link the record at hand to those and
452 only those records identified by them. This is convenient for handling web
453 forms with check boxes (or a SELECT box with multiple choice) that let you
454 update such (pseudo) relations.
455
456 For a description how to set up base classes for ResultSets see load_namespaces
457 in DBIx::Class::Schema.
458
459 =head1 DESIGN CHOICES
460
461 Columns and relationships which are excluded from the updates hashref aren't
462 touched at all.
463
464 =head2 Treatment of belongs_to relations
465
466 In case the relationship is included but undefined in the updates hashref,
467 all columns forming the relationship will be set to null.
468 If not all of them are nullable, DBIx::Class will throw an error.
469
470 Updating the relationship:
471
472 my $dvd = $dvd_rs->recursive_update( {
473 id => 1,
474 owner => $user->id,
475 });
476
477 Clearing the relationship (only works if cols are nullable!):
478
479 my $dvd = $dvd_rs->recursive_update( {
480 id => 1,
481 owner => undef,
482 });
483
484 =head2 Treatment of might_have relationships
485
486 In case the relationship is included but undefined in the updates hashref,
487 all columns forming the relationship will be set to null.
488
489 Updating the relationship:
490
491 my $user = $user_rs->recursive_update( {
492 id => 1,
493 address => {
494 street => "101 Main Street",
495 city => "Podunk",
496 state => "New York",
497 }
498 });
499
500 Clearing the relationship:
501
502 my $user = $user_rs->recursive_update( {
503 id => 1,
504 address => undef,
505 });
506
507 =head2 Treatment of has_many relations
508
509 If a relationship key is included in the data structure with a value of undef
510 or an empty array, all existing related rows will be deleted, or their foreign
511 key columns will be set to null.
512
513 The exact behaviour depends on the nullability of the foreign key columns and
514 the value of the "if_not_submitted" parameter. The parameter defaults to
515 undefined which neither nullifies nor deletes.
516
517 When the array contains elements they are updated if they exist, created when
518 not and deleted if not included.
519
520 =head3 All foreign table columns are nullable
521
522 In this case recursive_update defaults to nullifying the foreign columns.
523
524 =head3 Not all foreign table columns are nullable
525
526 In this case recursive_update deletes the foreign rows.
527
528 Updating the relationship:
529
530 Passing ids:
531
532 my $dvd = $dvd_rs->recursive_update( {
533 id => 1,
534 tags => [1, 2],
535 });
536
537 Passing hashrefs:
538
539 my $dvd = $dvd_rs->recursive_update( {
540 id => 1,
541 tags => [
542 {
543 id => 1,
544 file => 'file0'
545 },
546 {
547 id => 2,
548 file => 'file1',
549 },
550 ],
551 });
552
553 Passing objects:
554
555 TODO
556
557 You can even mix them:
558
559 my $dvd = $dvd_rs->recursive_update( {
560 id => 1,
561 tags => [ '2', { id => '3' } ],
562 });
563
564 Clearing the relationship:
565
566 my $dvd = $dvd_rs->recursive_update( {
567 id => 1,
568 tags => undef,
569 });
570
571 This is the same as passing an empty array:
572
573 my $dvd = $dvd_rs->recursive_update( {
574 id => 1,
575 tags => [],
576 });
577
578 =head2 Treatment of many-to-many pseudo relations
579
580 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
581 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
582 if($object->can($name) and
583 !$object->result_source->has_relationship($name) and
584 $object->can( 'set_' . $name )
585 )
586
587 then $name must be a many to many pseudo relation. And that in a
588 similarly ugly was I find out what is the ResultSource of objects from
589 that many to many pseudo relation.
590
591
592 =head1 INTERFACE
593
594 =head1 METHODS
595
596 =head2 recursive_update
597
598 The method that does the work here.
599
600 =head2 is_m2m
601
602 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
603 (pseudo) relation on $self.
604
605 =head2 get_m2m_source
606
607 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
608 to many (pseudo) relation 'name' from $self.
609
610
611 =head1 DIAGNOSTICS
612
613
614 =head1 CONFIGURATION AND ENVIRONMENT
615
616 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
617
618 =head1 DEPENDENCIES
619
620 DBIx::Class
621
622 =head1 INCOMPATIBILITIES
623
624 None reported.
625
626
627 =head1 BUGS AND LIMITATIONS
628
629 No bugs have been reported.
630
631 Please report any bugs or feature requests to
632 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
633 L<http://rt.cpan.org>.
634
635
636 =head1 AUTHOR
637
638 Zbigniew Lukasiak C<< <zby@cpan.org> >>
639 Influenced by code by Pedro Melo.
640
641 =head1 LICENCE AND COPYRIGHT
642
643 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
644
645 This module is free software; you can redistribute it and/or
646 modify it under the same terms as Perl itself. See L<perlartistic>.
647
648
649 =head1 DISCLAIMER OF WARRANTY
650
651 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
652 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
653 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
654 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
655 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
656 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
657 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
658 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
659 NECESSARY SERVICING, REPAIR, OR CORRECTION.
660
661 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
662 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
663 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
664 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
665 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
666 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
667 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
668 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
669 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
670 SUCH DAMAGES.
This page took 0.074834 seconds and 4 git commands to generate.