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