4 package DBIx
::Class
::ResultSet
::RecursiveUpdate
;
6 our $VERSION = '0.013';
8 use base
qw(DBIx::Class::ResultSet);
10 sub recursive_update
{
11 my ( $self, $updates, $fixed_fields ) = @_;
13 DBIx
::Class
::ResultSet
::RecursiveUpdate
::Functions
::recursive_update
(
16 fixed_fields
=> $fixed_fields
20 package DBIx
::Class
::ResultSet
::RecursiveUpdate
::Functions
;
22 use Scalar
::Util
qw( blessed );
24 sub recursive_update
{
26 my ( $self, $updates, $fixed_fields, $object, $resolved,
29 qw
/resultset updates fixed_fields object resolved if_not_submitted/};
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';
36 %fixed_fields = map { $_ => 1 } @$fixed_fields if $fixed_fields;
37 if ( blessed
($updates) && $updates->isa('DBIx::Class::Row') ) {
40 if ( $updates->{id
} ) {
41 $object = $self->find( $updates->{id
}, { key
=> 'primary' } );
44 grep { !exists $updates->{$_} && !exists $fixed_fields{$_} }
45 $self->result_source->primary_columns;
46 if ( !$object && !scalar @missing ) {
48 # warn 'finding by: ' . Dumper( $updates ); use Data::Dumper;
49 $object = $self->find( $updates, { key
=> 'primary' } );
51 $updates = { %$updates, %$resolved };
53 grep { !exists $resolved->{$_} } @missing;
54 if ( !$object && !scalar @missing ) {
56 # warn 'finding by +resolved: ' . Dumper( $updates ); use Data::Dumper;
57 $object = $self->find( $updates, { key
=> 'primary' } );
59 $object ||= $self->new( {} );
61 # warn Dumper( $updates ); use Data::Dumper;
62 # direct column accessors
65 # relations that that should be done before the row is inserted into the
66 # database like belongs_to
69 # relations that that should be done after the row is inserted into the
70 # database like has_many, might_have and has_one
73 my %columns_by_accessor = _get_columns_by_accessor
($self);
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} ) ) )
84 $columns{$name} = $updates->{$name};
87 if ( !( $source->has_relationship($name) ) ) {
88 $other_methods{$name} = $updates->{$name};
91 my $info = $source->relationship_info($name);
92 if (_master_relation_cond
(
93 $source, $info->{cond
},
94 _get_pk_for_related
( $self, $name )
98 $pre_updates{$name} = $updates->{$name};
101 $post_updates{$name} = $updates->{$name};
105 # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
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} );
112 for my $name ( keys %other_methods ) {
113 $object->$name( $updates->{$name} ) if $object->can($name);
115 for my $name ( keys %pre_updates ) {
116 my $info = $object->result_source->relationship_info($name);
117 _update_relation
( $self, $name, $updates, $object, $info,
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;
127 # updating many_to_many
128 for my $name ( keys %$updates ) {
129 next if exists $columns{$name};
130 my $value = $updates->{$name};
132 if ( is_m2m
( $self, $name ) ) {
133 my ($pk) = _get_pk_for_related
( $self, $name );
135 my $result_source = $object->$name->result_source;
137 if ( !defined $value ) {
140 elsif ( ref $value ) {
141 @updates = @{$value};
146 for my $elem (@updates) {
150 resultset
=> $result_source->resultset,
156 $result_source->resultset->find( { $pk => $elem } );
159 my $set_meth = 'set_' . $name;
160 $object->$set_meth( \
@rows );
163 for my $name ( keys %post_updates ) {
164 my $info = $object->result_source->relationship_info($name);
165 _update_relation
( $self, $name, $updates, $object, $info,
171 # returns DBIx::Class::ResultSource::column_info as a hash indexed by column accessor || name
172 sub _get_columns_by_accessor
{
174 my $source = $self->result_source;
176 for my $name ( $source->columns ) {
177 my $info = $source->column_info($name);
178 $info->{name
} = $name;
179 $columns{ $info->{accessor
} || $name } = $info;
184 sub _update_relation
{
185 my ( $self, $name, $updates, $object, $info, $if_not_submitted ) = @_;
187 $self->related_resultset($name)->result_source->resultset;
189 if ( $self->result_source->can('_resolve_condition') ) {
191 $self->result_source->_resolve_condition( $info->{cond
}, $name,
196 $self->result_source->resolve_condition( $info->{cond
}, $name,
200 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
202 if defined $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
203 && $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
205 if ( ref $updates->{$name} eq 'ARRAY' ) {
207 for my $sub_updates ( @{ $updates->{$name} } ) {
208 my $sub_object = recursive_update
(
209 resultset
=> $related_result,
210 updates
=> $sub_updates,
211 resolved
=> $resolved
213 push @updated_ids, $sub_object->id;
215 my @related_pks = $related_result->result_source->primary_columns;
216 if ( defined $if_not_submitted && $if_not_submitted eq 'delete' ) {
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 } } )
225 elsif ( defined $if_not_submitted
226 && $if_not_submitted eq 'set_to_null' )
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 } );
239 my $sub_updates = $updates->{$name};
241 if ( ref $sub_updates ) {
243 # for might_have relationship
244 if ( $info->{attrs
}{accessor
} eq 'single'
245 && defined $object->$name )
247 $sub_object = recursive_update
(
248 resultset
=> $related_result,
249 updates
=> $sub_updates,
250 object
=> $object->$name
254 $sub_object = recursive_update
(
255 resultset
=> $related_result,
256 updates
=> $sub_updates,
257 resolved
=> $resolved
261 elsif ( !ref $sub_updates ) {
262 $sub_object = $related_result->find($sub_updates)
265 && ( exists $info->{attrs
}{join_type
}
266 && $info->{attrs
}{join_type
} eq 'LEFT' )
269 $object->set_from_related( $name, $sub_object )
273 && ( exists $info->{attrs
}{join_type
}
274 && $info->{attrs
}{join_type
} eq 'LEFT' )
280 my ( $self, $relation ) = @_;
281 my $rclass = $self->result_class;
283 # DBIx::Class::IntrospectableM2M
284 if ( $rclass->can('_m2m_metadata') ) {
285 return $rclass->_m2m_metadata->{$relation};
287 my $object = $self->new( {} );
288 if ( $object->can($relation)
289 and !$self->result_source->has_relationship($relation)
290 and $object->can( 'set_' . $relation ) )
298 my ( $self, $relation ) = @_;
299 my $rclass = $self->result_class;
301 # DBIx::Class::IntrospectableM2M
302 if ( $rclass->can('_m2m_metadata') ) {
303 return $self->result_source->related_source(
304 $rclass->_m2m_metadata->{$relation}{relation
} )
306 $rclass->_m2m_metadata->{$relation}{foreign_relation
} );
308 my $object = $self->new( {} );
309 my $r = $object->$relation;
310 return $r->result_source;
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 '' )
321 delete $object->{_column_data
}{$col};
326 sub _get_pk_for_related
{
327 my ( $self, $relation ) = @_;
329 if ( $self->result_source->has_relationship($relation) ) {
330 $result_source = $self->result_source->related_source($relation);
334 if ( is_m2m
( $self, $relation ) ) {
335 $result_source = get_m2m_source
( $self, $relation );
337 return $result_source->primary_columns;
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} ) {
350 # might_have is not master
351 my $col = $cond->{$f_key};
353 if ( $source->column_info($col)->{is_auto_increment
} ) {
356 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
361 elsif ( ref $cond eq 'ARRAY' ) {
362 for my $new_cond (@$cond) {
363 return _master_relation_cond
( $source, $new_cond, @foreign_ids );
369 1; # Magic true value required at end of module
374 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
378 The functional interface:
380 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
381 resultset => $schema->resultset( 'Dvd' ),
386 title => 'One Flew Over the Cuckoo's Nest'
393 As ResultSet subclass:
395 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
397 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
401 my $user = $user_rs->recursive_update( {
405 title => 'One Flew Over the Cuckoo's Nest'
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.
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.
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
431 If the resultset itself stores an assignement for the primary key,
434 my $restricted_rs = $user_rs->search( { id => 1 } );
436 then you need to inform recursive_update about additional predicate with a second argument:
438 my $user = $restricted_rs->recursive_update( {
441 title => 'One Flew Over the Cuckoo's Nest'
448 This will work with a new DBIC release.
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.
456 For a description how to set up base classes for ResultSets see load_namespaces
457 in DBIx::Class::Schema.
459 =head1 DESIGN CHOICES
461 Columns and relationships which are excluded from the updates hashref aren't
464 =head2 Treatment of belongs_to relations
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.
470 Updating the relationship:
472 my $dvd = $dvd_rs->recursive_update( {
477 Clearing the relationship (only works if cols are nullable!):
479 my $dvd = $dvd_rs->recursive_update( {
484 =head2 Treatment of might_have relationships
486 In case the relationship is included but undefined in the updates hashref,
487 all columns forming the relationship will be set to null.
489 Updating the relationship:
491 my $user = $user_rs->recursive_update( {
494 street => "101 Main Street",
500 Clearing the relationship:
502 my $user = $user_rs->recursive_update( {
507 =head2 Treatment of has_many relations
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.
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.
517 When the array contains elements they are updated if they exist, created when
518 not and deleted if not included.
520 =head3 All foreign table columns are nullable
522 In this case recursive_update defaults to nullifying the foreign columns.
524 =head3 Not all foreign table columns are nullable
526 In this case recursive_update deletes the foreign rows.
528 Updating the relationship:
532 my $dvd = $dvd_rs->recursive_update( {
539 my $dvd = $dvd_rs->recursive_update( {
557 You can even mix them:
559 my $dvd = $dvd_rs->recursive_update( {
561 tags => [ '2', { id => '3' } ],
564 Clearing the relationship:
566 my $dvd = $dvd_rs->recursive_update( {
571 This is the same as passing an empty array:
573 my $dvd = $dvd_rs->recursive_update( {
578 =head2 Treatment of many-to-many pseudo relations
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 )
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.
596 =head2 recursive_update
598 The method that does the work here.
602 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
603 (pseudo) relation on $self.
605 =head2 get_m2m_source
607 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
608 to many (pseudo) relation 'name' from $self.
614 =head1 CONFIGURATION AND ENVIRONMENT
616 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
622 =head1 INCOMPATIBILITIES
627 =head1 BUGS AND LIMITATIONS
629 No bugs have been reported.
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>.
638 Zbigniew Lukasiak C<< <zby@cpan.org> >>
639 Influenced by code by Pedro Melo.
641 =head1 LICENCE AND COPYRIGHT
643 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
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>.
649 =head1 DISCLAIMER OF WARRANTY
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.
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