4 package DBIx
::Class
::ResultSet
::RecursiveUpdate
;
6 # ABSTRACT: like update_or_create - but recursive
8 use base
qw(DBIx::Class::ResultSet);
10 sub recursive_update
{
11 my ( $self, $updates, $attrs ) = @_;
14 my $unknown_params_ok;
17 if ( defined $attrs && ref $attrs eq 'HASH' ) {
18 $fixed_fields = $attrs->{fixed_fields
};
19 $unknown_params_ok = $attrs->{unknown_params_ok
};
23 elsif ( defined $attrs && ref $attrs eq 'ARRAY' ) {
24 $fixed_fields = $attrs;
28 DBIx
::Class
::ResultSet
::RecursiveUpdate
::Functions
::recursive_update
(
31 fixed_fields
=> $fixed_fields,
32 unknown_params_ok
=> $unknown_params_ok,
36 package DBIx
::Class
::ResultSet
::RecursiveUpdate
::Functions
;
37 use Carp
::Clan qw
/^DBIx::Class|^HTML::FormHandler|^Try::Tiny/;
38 use Scalar
::Util
qw( blessed );
39 use List
::MoreUtils qw
/ any /;
41 sub recursive_update
{
43 my ( $self, $updates, $fixed_fields, $object, $resolved,
44 $if_not_submitted, $unknown_params_ok )
46 qw
/resultset updates fixed_fields object resolved if_not_submitted unknown_params_ok/
50 my $source = $self->result_source;
52 # warn 'entering: ' . $source->from();
53 carp
'fixed fields needs to be an array ref'
54 if defined $fixed_fields && ref $fixed_fields ne 'ARRAY';
56 if ( blessed
($updates) && $updates->isa('DBIx::Class::Row') ) {
59 if ( exists $updates->{id
} ) {
60 # warn "finding object by id " . $updates->{id} . "\n";
61 $object = $self->find( $updates->{id
}, { key
=> 'primary' } );
62 # warn "object not found by id\n"
63 # unless defined $object;
66 my %fixed_fields = map { $_ => 1 } @$fixed_fields
69 grep { !exists $updates->{$_} && !exists $fixed_fields{$_} }
70 $source->primary_columns;
71 if ( !$object && !scalar @missing ) {
73 # warn 'finding by: ' . Dumper( $updates ); use Data::Dumper;
74 $object = $self->find( $updates, { key
=> 'primary' } );
76 $updates = { %$updates, %$resolved };
78 grep { !exists $resolved->{$_} } @missing;
79 if ( !$object && !scalar @missing ) {
81 # warn 'finding by +resolved: ' . Dumper( $updates ); use Data::Dumper;
82 $object = $self->find( $updates, { key
=> 'primary' } );
85 $object = $self->new( {} )
86 unless defined $object;
88 # warn Dumper( $updates ); use Data::Dumper;
89 # direct column accessors
92 # relations that that should be done before the row is inserted into the
93 # database like belongs_to
96 # relations that that should be done after the row is inserted into the
97 # database like has_many, might_have and has_one
101 my %columns_by_accessor = _get_columns_by_accessor
($self);
103 # warn 'resolved: ' . Dumper( $resolved );
104 # warn 'updates: ' . Dumper( $updates ); use Data::Dumper;
105 # warn 'columns: ' . Dumper( \%columns_by_accessor );
106 for my $name ( keys %$updates ) {
108 if ( exists $columns_by_accessor{$name}
109 && !( $source->has_relationship($name)
110 && ref( $updates->{$name} ) ) )
113 #warn "$name is a column\n";
114 $columns{$name} = $updates->{$name};
119 if ( $source->has_relationship($name) ) {
120 if ( _master_relation_cond
( $self, $name ) ) {
122 #warn "$name is a pre-update rel\n";
123 $pre_updates{$name} = $updates->{$name};
128 #warn "$name is a post-update rel\n";
129 $post_updates{$name} = $updates->{$name};
134 # many-to-many helper accessors
135 if ( is_m2m
( $self, $name ) ) {
137 #warn "$name is a many-to-many helper accessor\n";
138 $m2m_accessors{$name} = $updates->{$name};
143 if ( $object->can($name) && not $source->has_relationship($name) ) {
145 #warn "$name is an accessor";
146 $other_methods{$name} = $updates->{$name};
152 # don't throw a warning instead of an exception to give users
153 # time to adapt to the new API
155 "No such column, relationship, many-to-many helper accessor or generic accessor '$name'"
156 ) unless $unknown_params_ok;
158 #$self->throw_exception(
159 # "No such column, relationship, many-to-many helper accessor or generic accessor '$name'"
163 # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
165 # first update columns and other accessors
166 # so that later related records can be found
167 for my $name ( keys %columns ) {
169 #warn "update col $name\n";
170 $object->$name( $columns{$name} );
172 for my $name ( keys %other_methods ) {
174 #warn "update other $name\n";
175 $object->$name( $other_methods{$name} );
177 for my $name ( keys %pre_updates ) {
179 #warn "pre_update $name\n";
180 _update_relation
( $self, $name, $pre_updates{$name}, $object,
184 # $self->_delete_empty_auto_increment($object);
185 # don't allow insert to recurse to related objects
186 # do the recursion ourselves
187 # $object->{_rel_in_storage} = 1;
188 #warn "CHANGED: " . $object->is_changed . "\n";
189 #warn "IN STOR: " . $object->in_storage . "\n";
190 $object->update_or_insert if $object->is_changed;
191 $object->discard_changes;
193 # updating many_to_many
194 for my $name ( keys %m2m_accessors ) {
195 my $value = $m2m_accessors{$name};
197 #warn "update m2m $name\n";
198 # TODO: only first pk col is used
199 my ($pk) = _get_pk_for_related
( $self, $name );
201 my $result_source = $object->$name->result_source;
203 if ( !defined $value ) {
207 elsif ( ref $value ) {
208 @updates = @{$value};
213 for my $elem (@updates) {
217 # resultset => $result_source->resultset,
223 $result_source->resultset->find( { $pk => $elem } );
226 my $set_meth = 'set_' . $name;
227 $object->$set_meth( \
@rows );
229 for my $name ( keys %post_updates ) {
231 #warn "post_update $name\n";
232 _update_relation
( $self, $name, $post_updates{$name}, $object,
238 # returns DBIx::Class::ResultSource::column_info as a hash indexed by column accessor || name
239 sub _get_columns_by_accessor
{
241 my $source = $self->result_source;
243 for my $name ( $source->columns ) {
244 my $info = $source->column_info($name);
245 $info->{name
} = $name;
246 $columns{ $info->{accessor
} || $name } = $info;
251 # Arguments: $rs, $name, $updates, $row, $if_not_submitted
252 sub _update_relation
{
253 my ( $self, $name, $updates, $object, $if_not_submitted ) = @_;
255 # this should never happen because we're checking the paramters passed to
256 # recursive_update, but just to be sure...
257 $object->throw_exception("No such relationship '$name'")
258 unless $object->has_relationship($name);
260 #warn "_update_relation $name: OBJ: " . ref($object) . "\n";
262 my $info = $object->result_source->relationship_info($name);
264 # get a related resultset without a condition
265 my $related_resultset =
266 $self->related_resultset($name)->result_source->resultset;
268 if ( $self->result_source->can('_resolve_condition') ) {
270 $self->result_source->_resolve_condition( $info->{cond
}, $name,
274 $self->throw_exception(
275 "result_source must support _resolve_condition");
278 # warn "$name resolved: " . Dumper( $resolved ); use Data::Dumper;
280 if defined $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
281 && $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
284 my @rel_cols = keys %{ $info->{cond
} };
285 map {s/^foreign\.//} @rel_cols;
287 #warn "REL_COLS: " . Dumper(@rel_cols); use Data::Dumper;
288 #my $rel_col_cnt = scalar @rel_cols;
290 # find out if all related columns are nullable
291 my $all_fks_nullable = 1;
292 for my $rel_col (@rel_cols) {
293 $all_fks_nullable = 0
294 unless $related_resultset->result_source->column_info($rel_col)
298 $if_not_submitted = $all_fks_nullable ? 'nullify' : 'delete'
299 unless defined $if_not_submitted;
301 #warn "\tNULLABLE: $all_fks_nullable ACTION: $if_not_submitted\n";
303 #warn "RELINFO for $name: " . Dumper($info); use Data::Dumper;
305 # the only valid datatype for a has_many rels is an arrayref
306 if ( $info->{attrs
}{accessor
} eq 'multi' ) {
308 # handle undef like empty arrayref
310 unless defined $updates;
311 $self->throw_exception(
312 "data for has_many relationship '$name' must be an arrayref")
313 unless ref $updates eq 'ARRAY';
317 #warn "\tupdating has_many rel '$name' ($rel_col_cnt columns cols)\n";
318 for my $sub_updates ( @{$updates} ) {
319 my $sub_object = recursive_update
(
320 resultset
=> $related_resultset,
321 updates
=> $sub_updates,
322 resolved
=> $resolved
325 push @updated_objs, $sub_object;
328 #warn "\tcreated and updated related rows\n";
330 my @related_pks = $related_resultset->result_source->primary_columns;
332 my $rs_rel_delist = $object->$name;
334 # foreign table has a single pk column
335 if ( scalar @related_pks == 1 ) {
336 $rs_rel_delist = $rs_rel_delist->search_rs(
338 { -not_in
=> [ map ( $_->id, @updated_objs ) ] }
343 # foreign table has multiple pk columns
346 for my $obj (@updated_objs) {
348 for my $col (@related_pks) {
349 $cond_for_obj{$col} = $obj->get_column($col);
351 push @cond, \
%cond_for_obj;
354 # only limit resultset if there are related rows left
355 if ( scalar @cond ) {
357 $rs_rel_delist->search_rs( { -not => [@cond] } );
361 #warn "\tCOND: " . Dumper(\%cond);
362 #my $rel_delist_cnt = $rs_rel_delist->count;
363 if ( $if_not_submitted eq 'delete' ) {
365 #warn "\tdeleting related rows: $rel_delist_cnt\n";
366 $rs_rel_delist->delete;
368 elsif ( $if_not_submitted eq 'set_to_null' ) {
370 #warn "\tnullifying related rows: $rel_delist_cnt\n";
371 my %update = map { $_ => undef } @rel_cols;
372 $rs_rel_delist->update( \
%update );
375 elsif ($info->{attrs
}{accessor
} eq 'single'
376 || $info->{attrs
}{accessor
} eq 'filter' )
379 #warn "\tupdating rel '$name': $if_not_submitted\n";
381 if ( ref $updates ) {
383 # for might_have relationship
384 if ( $info->{attrs
}{accessor
} eq 'single'
385 && defined $object->$name )
387 $sub_object = recursive_update
(
388 resultset
=> $related_resultset,
390 object
=> $object->$name
394 $sub_object = recursive_update
(
395 resultset
=> $related_resultset,
397 resolved
=> $resolved
402 $sub_object = $related_resultset->find($updates)
405 && ( exists $info->{attrs
}{join_type
}
406 && $info->{attrs
}{join_type
} eq 'LEFT' )
409 $object->set_from_related( $name, $sub_object )
413 && ( exists $info->{attrs
}{join_type
}
414 && $info->{attrs
}{join_type
} eq 'LEFT' )
418 $self->throw_exception(
419 "recursive_update doesn't now how to handle relationship '$name' with accessor "
420 . $info->{attrs
}{accessor
} );
425 my ( $self, $relation ) = @_;
426 my $rclass = $self->result_class;
428 # DBIx::Class::IntrospectableM2M
429 if ( $rclass->can('_m2m_metadata') ) {
430 return $rclass->_m2m_metadata->{$relation};
432 my $object = $self->new( {} );
433 if ( $object->can($relation)
434 and !$self->result_source->has_relationship($relation)
435 and $object->can( 'set_' . $relation ) )
443 my ( $self, $relation ) = @_;
444 my $rclass = $self->result_class;
446 # DBIx::Class::IntrospectableM2M
447 if ( $rclass->can('_m2m_metadata') ) {
448 return $self->result_source->related_source(
449 $rclass->_m2m_metadata->{$relation}{relation
} )
451 $rclass->_m2m_metadata->{$relation}{foreign_relation
} );
453 my $object = $self->new( {} );
454 my $r = $object->$relation;
455 return $r->result_source;
458 sub _delete_empty_auto_increment
{
459 my ( $self, $object ) = @_;
460 for my $col ( keys %{ $object->{_column_data
} } ) {
461 if ($object->result_source->column_info($col)->{is_auto_increment
}
462 and ( !defined $object->{_column_data
}{$col}
463 or $object->{_column_data
}{$col} eq '' )
466 delete $object->{_column_data
}{$col};
471 sub _get_pk_for_related
{
472 my ( $self, $relation ) = @_;
474 if ( $self->result_source->has_relationship($relation) ) {
475 $result_source = $self->result_source->related_source($relation);
479 if ( is_m2m
( $self, $relation ) ) {
480 $result_source = get_m2m_source
( $self, $relation );
482 return $result_source->primary_columns;
485 # This function determines wheter a relationship should be done before or
486 # after the row is inserted into the database
487 # relationships before: belongs_to
488 # relationships after: has_many, might_have and has_one
489 # true means before, false after
490 sub _master_relation_cond
{
491 my ( $self, $name ) = @_;
493 my $source = $self->result_source;
494 my $info = $source->relationship_info($name);
496 #warn "INFO: " . Dumper($info) . "\n";
498 # has_many rels are always after
500 if $info->{attrs
}->{accessor
} eq 'multi';
502 my @foreign_ids = _get_pk_for_related
( $self, $name );
504 #warn "IDS: " . join(', ', @foreign_ids) . "\n";
506 my $cond = $info->{cond
};
509 my ( $source, $cond, @foreign_ids ) = @_;
511 while ( my ( $f_key, $col ) = each %{$cond} ) {
513 # might_have is not master
515 $f_key =~ s/^foreign\.//;
516 if ( $source->column_info($col)->{is_auto_increment
} ) {
519 if ( any
{ $_ eq $f_key } @foreign_ids ) {
526 if ( ref $cond eq 'HASH' ) {
527 return _inner
( $source, $cond, @foreign_ids );
530 # arrayref of hashrefs
531 elsif ( ref $cond eq 'ARRAY' ) {
532 for my $new_cond (@$cond) {
533 return _inner
( $source, $new_cond, @foreign_ids );
537 $source->throw_exception(
538 "unhandled relation condition " . ref($cond) );
543 1; # Magic true value required at end of module
548 # The functional interface:
550 my $schema = MyDB::Schema->connect();
551 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update(
552 resultset => $schema->resultset('User'),
557 title => "One Flew Over the Cuckoo's Nest"
561 unknown_params_ok => 1,
565 # As ResultSet subclass:
567 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
569 # in the Schema file (see t/lib/DBSchema.pm). Or appropriate 'use base' in the ResultSet classes.
571 my $user = $schema->resultset('User')->recursive_update({
575 title => "One Flew Over the Cuckoo's Nest"
579 unknown_params_ok => 1,
582 # You'll get a warning if you pass non-result specific data to
583 # recursive_update. See L</"Additional data in the updates hashref">
584 # for more information how to prevent this.
588 This is still experimental.
590 You can feed the ->create method of DBIx::Class with a recursive datastructure
591 and have the related records created. Unfortunately you cannot do a similar
592 thing with update_or_create. This module tries to fill that void until
593 L<DBIx::Class> has an api itself.
595 The functional interface can be used without modifications of the model,
596 for example by form processors like L<HTML::FormHandler::Model::DBIC>.
598 It is a base class for L<DBIx::Class::ResultSet>s providing the method
599 recursive_update which works just like update_or_create but can recursively
600 update or create result objects composed of multiple rows. All rows need to be
601 identified by primary keys so you need to provide them in the update structure
602 (unless they can be deduced from the parent row. For example a related row of
603 a belongs_to relationship). If any of the primary key columns are missing,
604 a new row will be created, with the expectation that the missing columns will
605 be filled by it (as in the case of auto_increment primary keys).
607 If the resultset itself stores an assignment for the primary key,
610 my $restricted_rs = $user_rs->search( { id => 1 } );
612 you need to inform recursive_update about the additional predicate with the fixed_fields attribute:
614 my $user = $restricted_rs->recursive_update( {
617 title => 'One Flew Over the Cuckoo's Nest'
622 fixed_fields => [ 'id' ],
626 For a many_to_many (pseudo) relation you can supply a list of primary keys
627 from the other table and it will link the record at hand to those and
628 only those records identified by them. This is convenient for handling web
629 forms with check boxes (or a select field with multiple choice) that lets you
630 update such (pseudo) relations.
632 For a description how to set up base classes for ResultSets see
633 L<DBIx::Class::Schema/load_namespaces>.
635 =head2 Additional data in the updates hashref
637 If you pass additional data to recursive_update which doesn't match a column
638 name, column accessor, relationship or many-to-many helper accessor, it will
639 throw a warning by default. To disable this behaviour you can set the
640 unknown_params_ok attribute to a true value.
642 The warning thrown is:
643 "No such column, relationship, many-to-many helper accessor or generic accessor '$key'"
645 When used by L<HTML::FormHandler::Model::DBIC> this can happen if you have
646 additional form fields that aren't relevant to the database but don't have the
647 noupdate attribute set to a true value.
649 NOTE: in a future version this behaviour will change and throw an exception
650 instead of a warning!
653 =head1 DESIGN CHOICES
655 Columns and relationships which are excluded from the updates hashref aren't
658 =head2 Treatment of belongs_to relations
660 In case the relationship is included but undefined in the updates hashref,
661 all columns forming the relationship will be set to null.
662 If not all of them are nullable, DBIx::Class will throw an error.
664 Updating the relationship:
666 my $dvd = $dvd_rs->recursive_update( {
671 Clearing the relationship (only works if cols are nullable!):
673 my $dvd = $dvd_rs->recursive_update( {
678 =head2 Treatment of might_have relationships
680 In case the relationship is included but undefined in the updates hashref,
681 all columns forming the relationship will be set to null.
683 Updating the relationship:
685 my $user = $user_rs->recursive_update( {
688 street => "101 Main Street",
694 Clearing the relationship:
696 my $user = $user_rs->recursive_update( {
701 =head2 Treatment of has_many relations
703 If a relationship key is included in the data structure with a value of undef
704 or an empty array, all existing related rows will be deleted, or their foreign
705 key columns will be set to null.
707 The exact behaviour depends on the nullability of the foreign key columns and
708 the value of the "if_not_submitted" parameter. The parameter defaults to
709 undefined which neither nullifies nor deletes.
711 When the array contains elements they are updated if they exist, created when
712 not and deleted if not included.
714 =head3 All foreign table columns are nullable
716 In this case recursive_update defaults to nullifying the foreign columns.
718 =head3 Not all foreign table columns are nullable
720 In this case recursive_update deletes the foreign rows.
722 Updating the relationship:
726 my $user = $user_rs->recursive_update( {
728 owned_dvds => [1, 2],
733 my $user = $user_rs->recursive_update( {
737 name => 'temp name 1',
740 name => 'temp name 2',
747 my $user = $user_rs->recursive_update( {
749 owned_dvds => [ $dvd1, $dvd2 ],
752 You can even mix them:
754 my $user = $user_rs->recursive_update( {
756 owned_dvds => [ 1, { id => 2 } ],
759 Clearing the relationship:
761 my $user = $user_rs->recursive_update( {
766 This is the same as passing an empty array:
768 my $user = $user_rs->recursive_update( {
773 =head2 Treatment of many-to-many pseudo relations
775 If a many-to-many accessor key is included in the data structure with a value
776 of undef or an empty array, all existing related rows are unlinked.
778 When the array contains elements they are updated if they exist, created when
779 not and deleted if not included.
781 See L</is_m2m> for many-to-many pseudo relationship detection.
783 Updating the relationship:
787 my $dvd = $dvd_rs->recursive_update( {
794 my $dvd = $dvd_rs->recursive_update( {
810 my $dvd = $dvd_rs->recursive_update( {
812 tags => [ $tag1, $tag2 ],
815 You can even mix them:
817 my $dvd = $dvd_rs->recursive_update( {
819 tags => [ 2, { id => 3 } ],
822 Clearing the relationship:
824 my $dvd = $dvd_rs->recursive_update( {
829 This is the same as passing an empty array:
831 my $dvd = $dvd_rs->recursive_update( {
841 =head2 recursive_update
843 The method that does the work here.
849 =item Arguments: $name
851 =item Return Value: true, if $name is a many to many pseudo-relationship
855 The function gets the information about m2m relations from
856 L<DBIx::Class::IntrospectableM2M>. If it isn't loaded in the ResultSource
857 class, the code relies on the fact:
859 if($object->can($name) and
860 !$object->result_source->has_relationship($name) and
861 $object->can( 'set_' . $name )
864 to identify a many to many pseudo relationship. In a similar ugly way the
865 ResultSource of that many to many pseudo relationship is detected.
867 So if you need many to many pseudo relationship support, it's strongly
868 recommended to load L<DBIx::Class::IntrospectableM2M> in your ResultSource
871 =head2 get_m2m_source
875 =item Arguments: $name
877 =item Return Value: $result_source
881 =head1 CONFIGURATION AND ENVIRONMENT
883 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
889 optional but recommended:
890 DBIx::Class::IntrospectableM2M
892 =head1 INCOMPATIBILITIES
897 =head1 BUGS AND LIMITATIONS
899 The list of reported bugs can be viewed at L<http://rt.cpan.org/Public/Dist/Display.html?Name=DBIx-Class-ResultSet-RecursiveUpdate>.
901 Please report any bugs or feature requests to
902 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
903 L<http://rt.cpan.org>.