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
100 my %columns_by_accessor = _get_columns_by_accessor
($self);
102 # warn 'resolved: ' . Dumper( $resolved );
103 # warn 'updates: ' . Dumper( $updates ); use Data::Dumper;
104 # warn 'columns: ' . Dumper( \%columns_by_accessor );
105 for my $name ( keys %$updates ) {
107 if ( exists $columns_by_accessor{$name}
108 && !( $source->has_relationship($name)
109 && ref( $updates->{$name} ) ) )
112 #warn "$name is a column\n";
113 $columns{$name} = $updates->{$name};
118 if ( $source->has_relationship($name) ) {
119 if ( _master_relation_cond
( $self, $name ) ) {
121 #warn "$name is a pre-update rel\n";
122 $pre_updates{$name} = $updates->{$name};
127 #warn "$name is a post-update rel\n";
128 $post_updates{$name} = $updates->{$name};
133 # many-to-many helper accessors
134 if ( is_m2m
( $self, $name ) ) {
136 #warn "$name is a many-to-many helper accessor\n";
137 $other_methods{$name} = $updates->{$name};
142 if ( $object->can($name) && not $source->has_relationship($name) ) {
144 #warn "$name is an accessor";
145 $other_methods{$name} = $updates->{$name};
151 # don't throw a warning instead of an exception to give users
152 # time to adapt to the new API
154 "No such column, relationship, many-to-many helper accessor or generic accessor '$name'"
155 ) unless $unknown_params_ok;
157 #$self->throw_exception(
158 # "No such column, relationship, many-to-many helper accessor or generic accessor '$name'"
162 # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
164 # first update columns and other accessors
165 # so that later related records can be found
166 for my $name ( keys %columns ) {
168 #warn "update col $name\n";
169 $object->$name( $columns{$name} );
171 for my $name ( keys %other_methods ) {
173 #warn "update other $name\n";
174 $object->$name( $updates->{$name} );
176 for my $name ( keys %pre_updates ) {
178 #warn "pre_update $name\n";
179 _update_relation
( $self, $name, $pre_updates{$name}, $object,
183 # $self->_delete_empty_auto_increment($object);
184 # don't allow insert to recurse to related objects
185 # do the recursion ourselves
186 # $object->{_rel_in_storage} = 1;
187 #warn "CHANGED: " . $object->is_changed . "\n":
188 #warn "IN STOR: " . $object->in_storage . "\n";
189 $object->update_or_insert if $object->is_changed;
190 $object->discard_changes;
192 # updating many_to_many
193 for my $name ( keys %$updates ) {
194 next if exists $columns{$name};
195 my $value = $updates->{$name};
197 if ( is_m2m
( $self, $name ) ) {
199 #warn "update m2m $name\n";
200 my ($pk) = _get_pk_for_related
( $self, $name );
202 my $result_source = $object->$name->result_source;
204 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 );
230 for my $name ( keys %post_updates ) {
232 #warn "post_update $name\n";
233 _update_relation
( $self, $name, $post_updates{$name}, $object,
239 # returns DBIx::Class::ResultSource::column_info as a hash indexed by column accessor || name
240 sub _get_columns_by_accessor
{
242 my $source = $self->result_source;
244 for my $name ( $source->columns ) {
245 my $info = $source->column_info($name);
246 $info->{name
} = $name;
247 $columns{ $info->{accessor
} || $name } = $info;
252 # Arguments: $rs, $name, $updates, $row, $if_not_submitted
253 sub _update_relation
{
254 my ( $self, $name, $updates, $object, $if_not_submitted ) = @_;
256 # this should never happen because we're checking the paramters passed to
257 # recursive_update, but just to be sure...
258 $object->throw_exception("No such relationship '$name'")
259 unless $object->has_relationship($name);
261 #warn "_update_relation $name: OBJ: " . ref($object) . "\n";
263 my $info = $object->result_source->relationship_info($name);
265 # get a related resultset without a condition
266 my $related_resultset =
267 $self->related_resultset($name)->result_source->resultset;
269 if ( $self->result_source->can('_resolve_condition') ) {
271 $self->result_source->_resolve_condition( $info->{cond
}, $name,
275 $self->throw_exception(
276 "result_source must support _resolve_condition");
279 # warn "$name resolved: " . Dumper( $resolved ); use Data::Dumper;
281 if defined $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
282 && $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
285 my @rel_cols = keys %{ $info->{cond
} };
286 map {s/^foreign\.//} @rel_cols;
288 #warn "REL_COLS: " . Dumper(@rel_cols); use Data::Dumper;
289 #my $rel_col_cnt = scalar @rel_cols;
291 # find out if all related columns are nullable
292 my $all_fks_nullable = 1;
293 for my $rel_col (@rel_cols) {
294 $all_fks_nullable = 0
295 unless $related_resultset->result_source->column_info($rel_col)
299 $if_not_submitted = $all_fks_nullable ? 'nullify' : 'delete'
300 unless defined $if_not_submitted;
302 #warn "\tNULLABLE: $all_fks_nullable ACTION: $if_not_submitted\n";
304 #warn "RELINFO for $name: " . Dumper($info); use Data::Dumper;
306 # the only valid datatype for a has_many rels is an arrayref
307 if ( $info->{attrs
}{accessor
} eq 'multi' ) {
309 # handle undef like empty arrayref
311 unless defined $updates;
312 $self->throw_exception(
313 "data for has_many relationship '$name' must be an arrayref")
314 unless ref $updates eq 'ARRAY';
318 #warn "\tupdating has_many rel '$name' ($rel_col_cnt columns cols)\n";
319 for my $sub_updates ( @{$updates} ) {
320 my $sub_object = recursive_update
(
321 resultset
=> $related_resultset,
322 updates
=> $sub_updates,
323 resolved
=> $resolved
326 push @updated_objs, $sub_object;
329 #warn "\tcreated and updated related rows\n";
331 my @related_pks = $related_resultset->result_source->primary_columns;
333 my $rs_rel_delist = $object->$name;
335 # foreign table has a single pk column
336 if ( scalar @related_pks == 1 ) {
337 $rs_rel_delist = $rs_rel_delist->search_rs(
339 { -not_in
=> [ map ( $_->id, @updated_objs ) ] }
344 # foreign table has multiple pk columns
347 for my $obj (@updated_objs) {
349 for my $col (@related_pks) {
350 $cond_for_obj{$col} = $obj->get_column($col);
352 push @cond, \
%cond_for_obj;
355 # only limit resultset if there are related rows left
356 if ( scalar @cond ) {
358 $rs_rel_delist->search_rs( { -not => [@cond] } );
362 #warn "\tCOND: " . Dumper(\%cond);
363 #my $rel_delist_cnt = $rs_rel_delist->count;
364 if ( $if_not_submitted eq 'delete' ) {
366 #warn "\tdeleting related rows: $rel_delist_cnt\n";
367 $rs_rel_delist->delete;
369 elsif ( $if_not_submitted eq 'set_to_null' ) {
371 #warn "\tnullifying related rows: $rel_delist_cnt\n";
372 my %update = map { $_ => undef } @rel_cols;
373 $rs_rel_delist->update( \
%update );
376 elsif ($info->{attrs
}{accessor
} eq 'single'
377 || $info->{attrs
}{accessor
} eq 'filter' )
380 #warn "\tupdating rel '$name': $if_not_submitted\n";
382 if ( ref $updates ) {
384 # for might_have relationship
385 if ( $info->{attrs
}{accessor
} eq 'single'
386 && defined $object->$name )
388 $sub_object = recursive_update
(
389 resultset
=> $related_resultset,
391 object
=> $object->$name
395 $sub_object = recursive_update
(
396 resultset
=> $related_resultset,
398 resolved
=> $resolved
403 $sub_object = $related_resultset->find($updates)
406 && ( exists $info->{attrs
}{join_type
}
407 && $info->{attrs
}{join_type
} eq 'LEFT' )
410 $object->set_from_related( $name, $sub_object )
414 && ( exists $info->{attrs
}{join_type
}
415 && $info->{attrs
}{join_type
} eq 'LEFT' )
419 $self->throw_exception(
420 "recursive_update doesn't now how to handle relationship '$name' with accessor "
421 . $info->{attrs
}{accessor
} );
426 my ( $self, $relation ) = @_;
427 my $rclass = $self->result_class;
429 # DBIx::Class::IntrospectableM2M
430 if ( $rclass->can('_m2m_metadata') ) {
431 return $rclass->_m2m_metadata->{$relation};
433 my $object = $self->new( {} );
434 if ( $object->can($relation)
435 and !$self->result_source->has_relationship($relation)
436 and $object->can( 'set_' . $relation ) )
444 my ( $self, $relation ) = @_;
445 my $rclass = $self->result_class;
447 # DBIx::Class::IntrospectableM2M
448 if ( $rclass->can('_m2m_metadata') ) {
449 return $self->result_source->related_source(
450 $rclass->_m2m_metadata->{$relation}{relation
} )
452 $rclass->_m2m_metadata->{$relation}{foreign_relation
} );
454 my $object = $self->new( {} );
455 my $r = $object->$relation;
456 return $r->result_source;
459 sub _delete_empty_auto_increment
{
460 my ( $self, $object ) = @_;
461 for my $col ( keys %{ $object->{_column_data
} } ) {
462 if ($object->result_source->column_info($col)->{is_auto_increment
}
463 and ( !defined $object->{_column_data
}{$col}
464 or $object->{_column_data
}{$col} eq '' )
467 delete $object->{_column_data
}{$col};
472 sub _get_pk_for_related
{
473 my ( $self, $relation ) = @_;
475 if ( $self->result_source->has_relationship($relation) ) {
476 $result_source = $self->result_source->related_source($relation);
480 if ( is_m2m
( $self, $relation ) ) {
481 $result_source = get_m2m_source
( $self, $relation );
483 return $result_source->primary_columns;
486 # This function determines wheter a relationship should be done before or
487 # after the row is inserted into the database
488 # relationships before: belongs_to
489 # relationships after: has_many, might_have and has_one
490 # true means before, false after
491 sub _master_relation_cond
{
492 my ( $self, $name ) = @_;
494 my $source = $self->result_source;
495 my $info = $source->relationship_info($name);
497 #warn "INFO: " . Dumper($info) . "\n";
499 # has_many rels are always after
501 if $info->{attrs
}->{accessor
} eq 'multi';
503 my @foreign_ids = _get_pk_for_related
( $self, $name );
505 #warn "IDS: " . join(', ', @foreign_ids) . "\n";
507 my $cond = $info->{cond
};
510 my ( $source, $cond, @foreign_ids ) = @_;
512 while ( my ( $f_key, $col ) = each %{$cond} ) {
514 # might_have is not master
516 $f_key =~ s/^foreign\.//;
517 if ( $source->column_info($col)->{is_auto_increment
} ) {
520 if ( any
{ $_ eq $f_key } @foreign_ids ) {
527 if ( ref $cond eq 'HASH' ) {
528 return _inner
( $source, $cond, @foreign_ids );
531 # arrayref of hashrefs
532 elsif ( ref $cond eq 'ARRAY' ) {
533 for my $new_cond (@$cond) {
534 return _inner
( $source, $new_cond, @foreign_ids );
538 $source->throw_exception(
539 "unhandled relation condition " . ref($cond) );
544 1; # Magic true value required at end of module
549 # The functional interface:
551 my $schema = MyDB::Schema->connect();
552 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update(
553 resultset => $schema->resultset('User'),
558 title => "One Flew Over the Cuckoo's Nest"
562 unknown_params_ok => 1,
566 # As ResultSet subclass:
568 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
570 # in the Schema file (see t/lib/DBSchema.pm). Or appropriate 'use base' in the ResultSet classes.
572 my $user = $schema->resultset('User')->recursive_update({
576 title => "One Flew Over the Cuckoo's Nest"
580 unknown_params_ok => 1,
583 # You'll get a warning if you pass non-result specific data to
584 # recursive_update. See L</"Additional data in the updates hashref">
585 # for more information how to prevent this.
589 This is still experimental.
591 You can feed the ->create method of DBIx::Class with a recursive datastructure
592 and have the related records created. Unfortunately you cannot do a similar
593 thing with update_or_create. This module tries to fill that void until
594 L<DBIx::Class> has an api itself.
596 The functional interface can be used without modifications of the model,
597 for example by form processors like L<HTML::FormHandler::Model::DBIC>.
599 It is a base class for L<DBIx::Class::ResultSet>s providing the method
600 recursive_update which works just like update_or_create but can recursively
601 update or create result objects composed of multiple rows. All rows need to be
602 identified by primary keys so you need to provide them in the update structure
603 (unless they can be deduced from the parent row. For example a related row of
604 a belongs_to relationship). If any of the primary key columns are missing,
605 a new row will be created, with the expectation that the missing columns will
606 be filled by it (as in the case of auto_increment primary keys).
608 If the resultset itself stores an assignment for the primary key,
611 my $restricted_rs = $user_rs->search( { id => 1 } );
613 you need to inform recursive_update about the additional predicate with the fixed_fields attribute:
615 my $user = $restricted_rs->recursive_update( {
618 title => 'One Flew Over the Cuckoo's Nest'
623 fixed_fields => [ 'id' ],
627 For a many_to_many (pseudo) relation you can supply a list of primary keys
628 from the other table and it will link the record at hand to those and
629 only those records identified by them. This is convenient for handling web
630 forms with check boxes (or a select field with multiple choice) that lets you
631 update such (pseudo) relations.
633 For a description how to set up base classes for ResultSets see
634 L<DBIx::Class::Schema/load_namespaces>.
636 =head2 Additional data in the updates hashref
638 If you pass additional data to recursive_update which doesn't match a column
639 name, column accessor, relationship or many-to-many helper accessor, it will
640 throw a warning by default. To disable this behaviour you can set the
641 unknown_params_ok attribute to a true value.
643 The warning thrown is:
644 "No such column, relationship, many-to-many helper accessor or generic accessor '$key'"
646 When used by L<HTML::FormHandler::Model::DBIC> this can happen if you have
647 additional form fields that aren't relevant to the database but don't have the
648 noupdate attribute set to a true value.
650 NOTE: in a future version this behaviour will change and throw an exception
651 instead of a warning!
654 =head1 DESIGN CHOICES
656 Columns and relationships which are excluded from the updates hashref aren't
659 =head2 Treatment of belongs_to relations
661 In case the relationship is included but undefined in the updates hashref,
662 all columns forming the relationship will be set to null.
663 If not all of them are nullable, DBIx::Class will throw an error.
665 Updating the relationship:
667 my $dvd = $dvd_rs->recursive_update( {
672 Clearing the relationship (only works if cols are nullable!):
674 my $dvd = $dvd_rs->recursive_update( {
679 =head2 Treatment of might_have relationships
681 In case the relationship is included but undefined in the updates hashref,
682 all columns forming the relationship will be set to null.
684 Updating the relationship:
686 my $user = $user_rs->recursive_update( {
689 street => "101 Main Street",
695 Clearing the relationship:
697 my $user = $user_rs->recursive_update( {
702 =head2 Treatment of has_many relations
704 If a relationship key is included in the data structure with a value of undef
705 or an empty array, all existing related rows will be deleted, or their foreign
706 key columns will be set to null.
708 The exact behaviour depends on the nullability of the foreign key columns and
709 the value of the "if_not_submitted" parameter. The parameter defaults to
710 undefined which neither nullifies nor deletes.
712 When the array contains elements they are updated if they exist, created when
713 not and deleted if not included.
715 =head3 All foreign table columns are nullable
717 In this case recursive_update defaults to nullifying the foreign columns.
719 =head3 Not all foreign table columns are nullable
721 In this case recursive_update deletes the foreign rows.
723 Updating the relationship:
727 my $user = $user_rs->recursive_update( {
729 owned_dvds => [1, 2],
734 my $user = $user_rs->recursive_update( {
738 name => 'temp name 1',
741 name => 'temp name 2',
748 my $user = $user_rs->recursive_update( {
750 owned_dvds => [ $dvd1, $dvd2 ],
753 You can even mix them:
755 my $user = $user_rs->recursive_update( {
757 owned_dvds => [ 1, { id => 2 } ],
760 Clearing the relationship:
762 my $user = $user_rs->recursive_update( {
767 This is the same as passing an empty array:
769 my $user = $user_rs->recursive_update( {
774 =head2 Treatment of many-to-many pseudo relations
776 If a many-to-many accessor key is included in the data structure with a value
777 of undef or an empty array, all existing related rows are unlinked.
779 When the array contains elements they are updated if they exist, created when
780 not and deleted if not included.
782 See L</is_m2m> for many-to-many pseudo relationship detection.
784 Updating the relationship:
788 my $dvd = $dvd_rs->recursive_update( {
795 my $dvd = $dvd_rs->recursive_update( {
811 my $dvd = $dvd_rs->recursive_update( {
813 tags => [ $tag1, $tag2 ],
816 You can even mix them:
818 my $dvd = $dvd_rs->recursive_update( {
820 tags => [ 2, { id => 3 } ],
823 Clearing the relationship:
825 my $dvd = $dvd_rs->recursive_update( {
830 This is the same as passing an empty array:
832 my $dvd = $dvd_rs->recursive_update( {
842 =head2 recursive_update
844 The method that does the work here.
850 =item Arguments: $name
852 =item Return Value: true, if $name is a many to many pseudo-relationship
856 The function gets the information about m2m relations from
857 L<DBIx::Class::IntrospectableM2M>. If it isn't loaded in the ResultSource
858 class, the code relies on the fact:
860 if($object->can($name) and
861 !$object->result_source->has_relationship($name) and
862 $object->can( 'set_' . $name )
865 to identify a many to many pseudo relationship. In a similar ugly way the
866 ResultSource of that many to many pseudo relationship is detected.
868 So if you need many to many pseudo relationship support, it's strongly
869 recommended to load L<DBIx::Class::IntrospectableM2M> in your ResultSource
872 =head2 get_m2m_source
876 =item Arguments: $name
878 =item Return Value: $result_source
882 =head1 CONFIGURATION AND ENVIRONMENT
884 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
890 optional but recommended:
891 DBIx::Class::IntrospectableM2M
893 =head1 INCOMPATIBILITIES
898 =head1 BUGS AND LIMITATIONS
900 The list of reported bugs can be viewed at L<http://rt.cpan.org/Public/Dist/Display.html?Name=DBIx-Class-ResultSet-RecursiveUpdate>.
902 Please report any bugs or feature requests to
903 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
904 L<http://rt.cpan.org>.