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->{$name}, $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->{$name}, $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 # Arguments: $name, $updates, $object, $info, $if_not_submitted
186 sub _update_relation
{
187 my ( $self, $name, $updates, $object, $info, $if_not_submitted ) = @_;
189 $self->related_resultset($name)->result_source->resultset;
191 if ( $self->result_source->can('_resolve_condition') ) {
193 $self->result_source->_resolve_condition( $info->{cond
}, $name,
198 $self->result_source->resolve_condition( $info->{cond
}, $name,
202 # warn "$name resolved: " . Dumper( $resolved ); use Data::Dumper;
204 if defined $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
205 && $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
208 # an arrayref is only valid for has_many rels
209 if ( ref $updates eq 'ARRAY' ) {
211 for my $sub_updates ( @{ $updates } ) {
212 my $sub_object = recursive_update
(
213 resultset
=> $related_result,
214 updates
=> $sub_updates,
215 resolved
=> $resolved
217 push @updated_ids, $sub_object->id;
219 my @related_pks = $related_result->result_source->primary_columns;
220 if ( defined $if_not_submitted && $if_not_submitted eq 'delete' ) {
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 } } )
229 elsif ( defined $if_not_submitted
230 && $if_not_submitted eq 'set_to_null' )
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 } );
244 if ( ref $updates ) {
246 # for might_have relationship
247 if ( $info->{attrs
}{accessor
} eq 'single'
248 && defined $object->$name )
250 $sub_object = recursive_update
(
251 resultset
=> $related_result,
253 object
=> $object->$name
257 $sub_object = recursive_update
(
258 resultset
=> $related_result,
260 resolved
=> $resolved
264 elsif ( !ref $updates ) {
265 $sub_object = $related_result->find($updates)
268 && ( exists $info->{attrs
}{join_type
}
269 && $info->{attrs
}{join_type
} eq 'LEFT' )
272 $object->set_from_related( $name, $sub_object )
276 && ( exists $info->{attrs
}{join_type
}
277 && $info->{attrs
}{join_type
} eq 'LEFT' )
283 my ( $self, $relation ) = @_;
284 my $rclass = $self->result_class;
286 # DBIx::Class::IntrospectableM2M
287 if ( $rclass->can('_m2m_metadata') ) {
288 return $rclass->_m2m_metadata->{$relation};
290 my $object = $self->new( {} );
291 if ( $object->can($relation)
292 and !$self->result_source->has_relationship($relation)
293 and $object->can( 'set_' . $relation ) )
301 my ( $self, $relation ) = @_;
302 my $rclass = $self->result_class;
304 # DBIx::Class::IntrospectableM2M
305 if ( $rclass->can('_m2m_metadata') ) {
306 return $self->result_source->related_source(
307 $rclass->_m2m_metadata->{$relation}{relation
} )
309 $rclass->_m2m_metadata->{$relation}{foreign_relation
} );
311 my $object = $self->new( {} );
312 my $r = $object->$relation;
313 return $r->result_source;
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 '' )
324 delete $object->{_column_data
}{$col};
329 sub _get_pk_for_related
{
330 my ( $self, $relation ) = @_;
332 if ( $self->result_source->has_relationship($relation) ) {
333 $result_source = $self->result_source->related_source($relation);
337 if ( is_m2m
( $self, $relation ) ) {
338 $result_source = get_m2m_source
( $self, $relation );
340 return $result_source->primary_columns;
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} ) {
353 # might_have is not master
354 my $col = $cond->{$f_key};
356 if ( $source->column_info($col)->{is_auto_increment
} ) {
359 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
364 elsif ( ref $cond eq 'ARRAY' ) {
365 for my $new_cond (@$cond) {
366 return _master_relation_cond
( $source, $new_cond, @foreign_ids );
372 1; # Magic true value required at end of module
377 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
381 The functional interface:
383 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
384 resultset => $schema->resultset( 'Dvd' ),
389 title => 'One Flew Over the Cuckoo's Nest'
396 As ResultSet subclass:
398 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
400 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
404 my $user = $user_rs->recursive_update( {
408 title => 'One Flew Over the Cuckoo's Nest'
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.
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.
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
434 If the resultset itself stores an assignement for the primary key,
437 my $restricted_rs = $user_rs->search( { id => 1 } );
439 then you need to inform recursive_update about additional predicate with a second argument:
441 my $user = $restricted_rs->recursive_update( {
444 title => 'One Flew Over the Cuckoo's Nest'
451 This will work with a new DBIC release.
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.
459 For a description how to set up base classes for ResultSets see load_namespaces
460 in DBIx::Class::Schema.
462 =head1 DESIGN CHOICES
464 Columns and relationships which are excluded from the updates hashref aren't
467 =head2 Treatment of belongs_to relations
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.
473 Updating the relationship:
475 my $dvd = $dvd_rs->recursive_update( {
480 Clearing the relationship (only works if cols are nullable!):
482 my $dvd = $dvd_rs->recursive_update( {
487 =head2 Treatment of might_have relationships
489 In case the relationship is included but undefined in the updates hashref,
490 all columns forming the relationship will be set to null.
492 Updating the relationship:
494 my $user = $user_rs->recursive_update( {
497 street => "101 Main Street",
503 Clearing the relationship:
505 my $user = $user_rs->recursive_update( {
510 =head2 Treatment of has_many relations
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.
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.
520 When the array contains elements they are updated if they exist, created when
521 not and deleted if not included.
523 =head3 All foreign table columns are nullable
525 In this case recursive_update defaults to nullifying the foreign columns.
527 =head3 Not all foreign table columns are nullable
529 In this case recursive_update deletes the foreign rows.
531 Updating the relationship:
535 my $dvd = $dvd_rs->recursive_update( {
542 my $dvd = $dvd_rs->recursive_update( {
560 You can even mix them:
562 my $dvd = $dvd_rs->recursive_update( {
564 tags => [ '2', { id => '3' } ],
567 Clearing the relationship:
569 my $dvd = $dvd_rs->recursive_update( {
574 This is the same as passing an empty array:
576 my $dvd = $dvd_rs->recursive_update( {
581 =head2 Treatment of many-to-many pseudo relations
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:
586 if($object->can($name) and
587 !$object->result_source->has_relationship($name) and
588 $object->can( 'set_' . $name )
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.
600 =head2 recursive_update
602 The method that does the work here.
606 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
607 (pseudo) relation on $self.
609 =head2 get_m2m_source
611 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
612 to many (pseudo) relation 'name' from $self.
618 =head1 CONFIGURATION AND ENVIRONMENT
620 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
626 =head1 INCOMPATIBILITIES
631 =head1 BUGS AND LIMITATIONS
633 No bugs have been reported.
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>.
642 Zbigniew Lukasiak C<< <zby@cpan.org> >>
643 Influenced by code by Pedro Melo.
645 =head1 LICENCE AND COPYRIGHT
647 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
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>.
653 =head1 DISCLAIMER OF WARRANTY
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.
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