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