don't try to use ->resolve_condition which was deprecated in DBIx::Class 0.08103...
[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 _update_relation( $self, $name, $updates->{$name}, $object,
117 $if_not_submitted );
118 }
119
120 # $self->_delete_empty_auto_increment($object);
121 # don't allow insert to recurse to related objects
122 # do the recursion ourselves
123 # $object->{_rel_in_storage} = 1;
124 $object->update_or_insert if $object->is_changed;
125
126 # updating many_to_many
127 for my $name ( keys %$updates ) {
128 next if exists $columns{$name};
129 my $value = $updates->{$name};
130
131 if ( is_m2m( $self, $name ) ) {
132 my ($pk) = _get_pk_for_related( $self, $name );
133 my @rows;
134 my $result_source = $object->$name->result_source;
135 my @updates;
136 if ( !defined $value ) {
137 next;
138 }
139 elsif ( ref $value ) {
140 @updates = @{$value};
141 }
142 else {
143 @updates = ($value);
144 }
145 for my $elem (@updates) {
146 if ( ref $elem ) {
147 push @rows,
148 recursive_update(
149 resultset => $result_source->resultset,
150 updates => $elem
151 );
152 }
153 else {
154 push @rows,
155 $result_source->resultset->find( { $pk => $elem } );
156 }
157 }
158 my $set_meth = 'set_' . $name;
159 $object->$set_meth( \@rows );
160 }
161 }
162 for my $name ( keys %post_updates ) {
163 _update_relation( $self, $name, $updates->{$name}, $object,
164 $if_not_submitted );
165 }
166 return $object;
167 }
168
169 # returns DBIx::Class::ResultSource::column_info as a hash indexed by column accessor || name
170 sub _get_columns_by_accessor {
171 my $self = shift;
172 my $source = $self->result_source;
173 my %columns;
174 for my $name ( $source->columns ) {
175 my $info = $source->column_info($name);
176 $info->{name} = $name;
177 $columns{ $info->{accessor} || $name } = $info;
178 }
179 return %columns;
180 }
181
182 # Arguments: $name, $updates, $object, $if_not_submitted
183
184 sub _update_relation {
185 my ( $self, $name, $updates, $object, $if_not_submitted ) = @_;
186 my $info = $object->result_source->relationship_info($name);
187
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
198 # warn "$name resolved: " . Dumper( $resolved ); use Data::Dumper;
199 $resolved = {}
200 if defined $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
201 && $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
202 == $resolved;
203
204 # an arrayref is only valid for has_many rels
205 if ( ref $updates eq 'ARRAY' ) {
206 my @updated_ids;
207 for my $sub_updates ( @{$updates} ) {
208 my $sub_object = recursive_update(
209 resultset => $related_resultset,
210 updates => $sub_updates,
211 resolved => $resolved
212 );
213 push @updated_ids, $sub_object->id;
214 }
215 my @related_pks = $related_resultset->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_object;
240 if ( ref $updates ) {
241
242 # for might_have relationship
243 if ( $info->{attrs}{accessor} eq 'single'
244 && defined $object->$name )
245 {
246 $sub_object = recursive_update(
247 resultset => $related_resultset,
248 updates => $updates,
249 object => $object->$name
250 );
251 }
252 else {
253 $sub_object = recursive_update(
254 resultset => $related_resultset,
255 updates => $updates,
256 resolved => $resolved
257 );
258 }
259 }
260 elsif ( !ref $updates ) {
261 $sub_object = $related_resultset->find($updates)
262 unless (
263 !$updates
264 && ( exists $info->{attrs}{join_type}
265 && $info->{attrs}{join_type} eq 'LEFT' )
266 );
267 }
268 $object->set_from_related( $name, $sub_object )
269 unless (
270 !$sub_object
271 && !$updates
272 && ( exists $info->{attrs}{join_type}
273 && $info->{attrs}{join_type} eq 'LEFT' )
274 );
275 }
276 }
277
278 sub is_m2m {
279 my ( $self, $relation ) = @_;
280 my $rclass = $self->result_class;
281
282 # DBIx::Class::IntrospectableM2M
283 if ( $rclass->can('_m2m_metadata') ) {
284 return $rclass->_m2m_metadata->{$relation};
285 }
286 my $object = $self->new( {} );
287 if ( $object->can($relation)
288 and !$self->result_source->has_relationship($relation)
289 and $object->can( 'set_' . $relation ) )
290 {
291 return 1;
292 }
293 return;
294 }
295
296 sub get_m2m_source {
297 my ( $self, $relation ) = @_;
298 my $rclass = $self->result_class;
299
300 # DBIx::Class::IntrospectableM2M
301 if ( $rclass->can('_m2m_metadata') ) {
302 return $self->result_source->related_source(
303 $rclass->_m2m_metadata->{$relation}{relation} )
304 ->related_source(
305 $rclass->_m2m_metadata->{$relation}{foreign_relation} );
306 }
307 my $object = $self->new( {} );
308 my $r = $object->$relation;
309 return $r->result_source;
310 }
311
312 sub _delete_empty_auto_increment {
313 my ( $self, $object ) = @_;
314 for my $col ( keys %{ $object->{_column_data} } ) {
315 if ($object->result_source->column_info($col)->{is_auto_increment}
316 and ( !defined $object->{_column_data}{$col}
317 or $object->{_column_data}{$col} eq '' )
318 )
319 {
320 delete $object->{_column_data}{$col};
321 }
322 }
323 }
324
325 sub _get_pk_for_related {
326 my ( $self, $relation ) = @_;
327 my $result_source;
328 if ( $self->result_source->has_relationship($relation) ) {
329 $result_source = $self->result_source->related_source($relation);
330 }
331
332 # many to many case
333 if ( is_m2m( $self, $relation ) ) {
334 $result_source = get_m2m_source( $self, $relation );
335 }
336 return $result_source->primary_columns;
337 }
338
339 # This function determines wheter a relationship should be done before or
340 # after the row is inserted into the database
341 # relationships before: belongs_to
342 # relationships after: has_many, might_have and has_one
343 sub _master_relation_cond {
344 my ( $source, $cond, @foreign_ids ) = @_;
345 my $foreign_ids_re = join '|', @foreign_ids;
346 if ( ref $cond eq 'HASH' ) {
347 for my $f_key ( keys %{$cond} ) {
348
349 # might_have is not master
350 my $col = $cond->{$f_key};
351 $col =~ s/self\.//;
352 if ( $source->column_info($col)->{is_auto_increment} ) {
353 return 0;
354 }
355 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
356 return 1;
357 }
358 }
359 }
360 elsif ( ref $cond eq 'ARRAY' ) {
361 for my $new_cond (@$cond) {
362 return _master_relation_cond( $source, $new_cond, @foreign_ids );
363 }
364 }
365 return;
366 }
367
368 1; # Magic true value required at end of module
369 __END__
370
371 =head1 NAME
372
373 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
374
375 =head1 SYNOPSIS
376
377 The functional interface:
378
379 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
380 resultset => $schema->resultset( 'Dvd' ),
381 updates => {
382 id => 1,
383 owned_dvds => [
384 {
385 title => 'One Flew Over the Cuckoo's Nest'
386 }
387 ]
388 }
389 });
390
391
392 As ResultSet subclass:
393
394 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
395
396 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
397
398 Then:
399
400 my $user = $user_rs->recursive_update( {
401 id => 1,
402 owned_dvds => [
403 {
404 title => 'One Flew Over the Cuckoo's Nest'
405 }
406 ]
407 }
408 );
409
410
411 =head1 DESCRIPTION
412
413 This is still experimental. I've added a functional interface so that it can be used
414 in Form Processors and not require modification of the model.
415
416 You can feed the ->create method with a recursive datastructure and have the related records
417 created. Unfortunately you cannot do a similar thing with update_or_create - this module
418 tries to fill that void.
419
420 It is a base class for ResultSets providing just one method: recursive_update
421 which works just like update_or_create but can recursively update or create
422 data objects composed of multiple rows. All rows need to be identified by primary keys
423 - so you need to provide them in the update structure (unless they can be deduced from
424 the parent row - for example when you have a belongs_to relationship).
425 If not all colums comprising the primary key are specified - then a new row will be created,
426 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
427 primary keys).
428
429
430 If the resultset itself stores an assignement for the primary key,
431 like in the case of:
432
433 my $restricted_rs = $user_rs->search( { id => 1 } );
434
435 then you need to inform recursive_update about additional predicate with a second argument:
436
437 my $user = $restricted_rs->recursive_update( {
438 owned_dvds => [
439 {
440 title => 'One Flew Over the Cuckoo's Nest'
441 }
442 ]
443 },
444 [ 'id' ]
445 );
446
447 This will work with a new DBIC release.
448
449 For a many_to_many (pseudo) relation you can supply a list of primary keys
450 from the other table - and it will link the record at hand to those and
451 only those records identified by them. This is convenient for handling web
452 forms with check boxes (or a SELECT box with multiple choice) that let you
453 update such (pseudo) relations.
454
455 For a description how to set up base classes for ResultSets see load_namespaces
456 in DBIx::Class::Schema.
457
458 =head1 DESIGN CHOICES
459
460 Columns and relationships which are excluded from the updates hashref aren't
461 touched at all.
462
463 =head2 Treatment of belongs_to relations
464
465 In case the relationship is included but undefined in the updates hashref,
466 all columns forming the relationship will be set to null.
467 If not all of them are nullable, DBIx::Class will throw an error.
468
469 Updating the relationship:
470
471 my $dvd = $dvd_rs->recursive_update( {
472 id => 1,
473 owner => $user->id,
474 });
475
476 Clearing the relationship (only works if cols are nullable!):
477
478 my $dvd = $dvd_rs->recursive_update( {
479 id => 1,
480 owner => undef,
481 });
482
483 =head2 Treatment of might_have relationships
484
485 In case the relationship is included but undefined in the updates hashref,
486 all columns forming the relationship will be set to null.
487
488 Updating the relationship:
489
490 my $user = $user_rs->recursive_update( {
491 id => 1,
492 address => {
493 street => "101 Main Street",
494 city => "Podunk",
495 state => "New York",
496 }
497 });
498
499 Clearing the relationship:
500
501 my $user = $user_rs->recursive_update( {
502 id => 1,
503 address => undef,
504 });
505
506 =head2 Treatment of has_many relations
507
508 If a relationship key is included in the data structure with a value of undef
509 or an empty array, all existing related rows will be deleted, or their foreign
510 key columns will be set to null.
511
512 The exact behaviour depends on the nullability of the foreign key columns and
513 the value of the "if_not_submitted" parameter. The parameter defaults to
514 undefined which neither nullifies nor deletes.
515
516 When the array contains elements they are updated if they exist, created when
517 not and deleted if not included.
518
519 =head3 All foreign table columns are nullable
520
521 In this case recursive_update defaults to nullifying the foreign columns.
522
523 =head3 Not all foreign table columns are nullable
524
525 In this case recursive_update deletes the foreign rows.
526
527 Updating the relationship:
528
529 Passing ids:
530
531 my $dvd = $dvd_rs->recursive_update( {
532 id => 1,
533 tags => [1, 2],
534 });
535
536 Passing hashrefs:
537
538 my $dvd = $dvd_rs->recursive_update( {
539 id => 1,
540 tags => [
541 {
542 id => 1,
543 file => 'file0'
544 },
545 {
546 id => 2,
547 file => 'file1',
548 },
549 ],
550 });
551
552 Passing objects:
553
554 TODO
555
556 You can even mix them:
557
558 my $dvd = $dvd_rs->recursive_update( {
559 id => 1,
560 tags => [ '2', { id => '3' } ],
561 });
562
563 Clearing the relationship:
564
565 my $dvd = $dvd_rs->recursive_update( {
566 id => 1,
567 tags => undef,
568 });
569
570 This is the same as passing an empty array:
571
572 my $dvd = $dvd_rs->recursive_update( {
573 id => 1,
574 tags => [],
575 });
576
577 =head2 Treatment of many-to-many pseudo relations
578
579 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
580 If it isn't loaded in the ResultSource classes the code relies on the fact that:
581
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.
588 And that in a similarly ugly was I find out what is the ResultSource of
589 objects from 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.083059 seconds and 4 git commands to generate.