3 package DBIx
::Class
::ResultSet
::RecursiveUpdate
;
5 our $VERSION = '0.013';
7 use base
qw(DBIx::Class::ResultSet);
10 my ( $self, $updates, $fixed_fields ) = @_;
11 return DBIx
::Class
::ResultSet
::RecursiveUpdate
::Functions
::recursive_update
(
14 fixed_fields
=> $fixed_fields
18 package DBIx
::Class
::ResultSet
::RecursiveUpdate
::Functions
;
20 use Scalar
::Util
qw( blessed );
23 sub recursive_update
{
25 my ( $self, $updates, $fixed_fields, $object, $resolved, $if_not_submitted ) = @params{ qw
/resultset updates fixed_fields object resolved if_not_submitted/ };
27 # warn 'entering: ' . $self->result_source->from();
28 carp
'fixed fields needs to be an array ref' if $fixed_fields && ref($fixed_fields) ne 'ARRAY';
30 %fixed_fields = map { $_ => 1 } @$fixed_fields if $fixed_fields;
31 if ( blessed
($updates) && $updates->isa('DBIx::Class::Row') ) {
34 if ( $updates->{id
} ){
35 $object = $self->find( $updates->{id
}, { key
=> 'primary' } );
38 grep { !exists $updates->{$_} && !exists $fixed_fields{$_} } $self->result_source->primary_columns;
39 if ( !$object && !scalar @missing ) {
40 # warn 'finding by: ' . Dumper( $updates ); use Data::Dumper;
41 $object = $self->find( $updates, { key
=> 'primary' } );
43 $updates = { %$updates, %$resolved };
45 grep { !exists $resolved->{$_} } @missing;
46 if ( !$object && !scalar @missing ) {
47 # warn 'finding by +resolved: ' . Dumper( $updates ); use Data::Dumper;
48 $object = $self->find( $updates, { key
=> 'primary' } );
50 $object ||= $self->new( {} );
51 # warn Dumper( $updates ); use Data::Dumper;
52 # direct column accessors
55 # relations that that should be done before the row is inserted into the database
59 # relations that that should be done after the row is inserted into the database
60 # like has_many and might_have
63 my %columns_by_accessor = _get_columns_by_accessor
( $self );
64 # warn 'resolved: ' . Dumper( $resolved );
65 # warn 'updates: ' . Dumper( $updates ); use Data::Dumper;
66 # warn 'columns: ' . Dumper( \%columns_by_accessor );
67 for my $name ( keys %$updates ) {
68 my $source = $self->result_source;
69 if ( $columns_by_accessor{$name}
70 && !( $source->has_relationship($name) && ref( $updates->{$name} ) )
73 $columns{$name} = $updates->{$name};
76 if( !( $source->has_relationship($name) ) ){
77 $other_methods{$name} = $updates->{$name};
80 my $info = $source->relationship_info($name);
82 _master_relation_cond
(
83 $source, $info->{cond
}, _get_pk_for_related
( $self, $name)
87 $pre_updates{$name} = $updates->{$name};
90 $post_updates{$name} = $updates->{$name};
93 # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
95 # first update columns and other accessors - so that later related records can be found
96 for my $name ( keys %columns ) {
97 $object->$name( $columns{$name} );
99 for my $name ( keys %other_methods) {
100 $object->$name( $updates->{$name} ) if $object->can( $name );
102 for my $name ( keys %pre_updates ) {
103 my $info = $object->result_source->relationship_info($name);
104 _update_relation
( $self, $name, $updates, $object, $info, $if_not_submitted );
106 # $self->_delete_empty_auto_increment($object);
107 # don't allow insert to recurse to related objects - we do the recursion ourselves
108 # $object->{_rel_in_storage} = 1;
110 $object->update_or_insert if $object->is_changed;
112 # updating many_to_many
113 for my $name ( keys %$updates ) {
114 next if exists $columns{$name};
115 my $value = $updates->{$name};
117 if ( is_m2m
( $self, $name) ) {
118 my ($pk) = _get_pk_for_related
( $self, $name);
120 my $result_source = $object->$name->result_source;
122 if( ! defined $value ){
126 @updates = @{ $value };
129 @updates = ( $value );
131 for my $elem ( @updates ) {
133 push @rows, recursive_update
( resultset
=> $result_source->resultset, updates
=> $elem );
137 $result_source->resultset->find( { $pk => $elem } );
140 my $set_meth = 'set_' . $name;
141 $object->$set_meth( \
@rows );
144 for my $name ( keys %post_updates ) {
145 my $info = $object->result_source->relationship_info($name);
146 _update_relation
( $self, $name, $updates, $object, $info, $if_not_submitted );
151 sub _get_columns_by_accessor
{
153 my $source = $self->result_source;
155 for my $name ( $source->columns ) {
156 my $info = $source->column_info($name);
157 $info->{name
} = $name;
158 $columns{ $info->{accessor
} || $name } = $info;
163 sub _update_relation
{
164 my ( $self, $name, $updates, $object, $info, $if_not_submitted ) = @_;
166 $self->related_resultset($name)->result_source->resultset;
168 if( $self->result_source->can( '_resolve_condition' ) ){
169 $resolved = $self->result_source->_resolve_condition( $info->{cond
}, $name, $object );
172 $resolved = $self->result_source->resolve_condition( $info->{cond
}, $name, $object );
175 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
177 if defined $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
&& $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
== $resolved;
178 if ( ref $updates->{$name} eq 'ARRAY' ) {
180 for my $sub_updates ( @{ $updates->{$name} } ) {
182 recursive_update
( resultset
=> $related_result, updates
=> $sub_updates, resolved
=> $resolved );
183 push @updated_ids, $sub_object->id;
185 my @related_pks = $related_result->result_source->primary_columns;
186 if( defined $if_not_submitted && $if_not_submitted eq 'delete' ){
187 if ( 1 == scalar @related_pks ){
188 $object->$name->search( { $related_pks[0] => { -not_in
=> \
@updated_ids } } )->delete;
191 elsif( defined $if_not_submitted && $if_not_submitted eq 'set_to_null' ){
192 if ( 1 == scalar @related_pks ){
193 my @fk = keys %$resolved;
194 $object->$name->search( { $related_pks[0] => { -not_in
=> \
@updated_ids } } )->update( { $fk[0] => undef } );
199 my $sub_updates = $updates->{$name};
201 if( ref $sub_updates ){
202 # for might_have relationship
203 if( $info->{attrs
}{accessor
} eq 'single' && defined $object->$name ){
204 $sub_object = recursive_update
(
205 resultset
=> $related_result,
206 updates
=> $sub_updates,
207 object
=> $object->$name
212 recursive_update
( resultset
=> $related_result, updates
=> $sub_updates, resolved
=> $resolved );
215 elsif( ! ref $sub_updates ){
216 $sub_object = $related_result->find( $sub_updates )
217 unless (!$sub_updates && (exists $info->{attrs
}{join_type
} && $info->{attrs
}{join_type
} eq 'LEFT'));
219 $object->set_from_related( $name, $sub_object )
220 unless (!$sub_object && !$sub_updates && (exists $info->{attrs
}{join_type
} && $info->{attrs
}{join_type
} eq 'LEFT'));
225 my ( $self, $relation ) = @_;
226 my $rclass = $self->result_class;
228 # DBIx::Class::IntrospectableM2M
229 if ( $rclass->can('_m2m_metadata') ) {
230 return $rclass->_m2m_metadata->{$relation};
232 my $object = $self->new( {} );
233 if ( $object->can($relation)
234 and !$self->result_source->has_relationship($relation)
235 and $object->can( 'set_' . $relation ) )
243 my ( $self, $relation ) = @_;
244 my $rclass = $self->result_class;
246 # DBIx::Class::IntrospectableM2M
247 if ( $rclass->can('_m2m_metadata') ) {
248 return $self->result_source->related_source(
249 $rclass->_m2m_metadata->{$relation}{relation
} )
251 $rclass->_m2m_metadata->{$relation}{foreign_relation
} );
253 my $object = $self->new( {} );
254 my $r = $object->$relation;
255 return $r->result_source;
258 sub _delete_empty_auto_increment
{
259 my ( $self, $object ) = @_;
260 for my $col ( keys %{ $object->{_column_data
} } ) {
262 $object->result_source->column_info($col)->{is_auto_increment
}
263 and ( !defined $object->{_column_data
}{$col}
264 or $object->{_column_data
}{$col} eq '' )
267 delete $object->{_column_data
}{$col};
272 sub _get_pk_for_related
{
273 my ( $self, $relation ) = @_;
275 if ( $self->result_source->has_relationship($relation) ) {
276 $result_source = $self->result_source->related_source($relation);
280 if ( is_m2m
($self, $relation) ) {
281 $result_source = get_m2m_source
($self, $relation);
283 return $result_source->primary_columns;
286 sub _master_relation_cond
{
287 my ( $source, $cond, @foreign_ids ) = @_;
288 my $foreign_ids_re = join '|', @foreign_ids;
289 if ( ref $cond eq 'HASH' ) {
290 for my $f_key ( keys %{$cond} ) {
292 # might_have is not master
293 my $col = $cond->{$f_key};
295 if ( $source->column_info($col)->{is_auto_increment
} ) {
298 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
303 elsif ( ref $cond eq 'ARRAY' ) {
304 for my $new_cond (@$cond) {
306 if _master_relation_cond
( $source, $new_cond, @foreign_ids );
312 1; # Magic true value required at end of module
317 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
321 The functional interface:
323 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
324 resultset => $schema->resultset( 'Dvd' ),
329 title => 'One Flew Over the Cuckoo's Nest'
336 As ResultSet subclass:
338 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
340 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
344 my $user = $user_rs->recursive_update( {
348 title => 'One Flew Over the Cuckoo's Nest'
356 This is still experimental. I've added a functional interface so that it can be used
357 in Form Processors and not require modification of the model.
359 You can feed the ->create method with a recursive datastructure and have the related records
360 created. Unfortunately you cannot do a similar thing with update_or_create - this module
361 tries to fill that void.
363 It is a base class for ResultSets providing just one method: recursive_update
364 which works just like update_or_create but can recursively update or create
365 data objects composed of multiple rows. All rows need to be identified by primary keys
366 - so you need to provide them in the update structure (unless they can be deduced from
367 the parent row - for example when you have a belongs_to relationship).
368 If not all colums comprising the primary key are specified - then a new row will be created,
369 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
373 If the resultset itself stores an assignement for the primary key,
376 my $restricted_rs = $user_rs->search( { id => 1 } );
378 then you need to inform recursive_update about additional predicate with a second argument:
380 my $user = $restricted_rs->recursive_update( {
383 title => 'One Flew Over the Cuckoo's Nest'
390 This will work with a new DBIC release.
392 For a many_to_many (pseudo) relation you can supply a list of primary keys
393 from the other table - and it will link the record at hand to those and
394 only those records identified by them. This is convenient for handling web
395 forms with check boxes (or a SELECT box with multiple choice) that let you
396 update such (pseudo) relations.
398 For a description how to set up base classes for ResultSets see load_namespaces
399 in DBIx::Class::Schema.
401 =head1 DESIGN CHOICES
403 =head2 Treatment of many to many pseudo relations
405 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
406 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
407 if($object->can($name) and
408 !$object->result_source->has_relationship($name) and
409 $object->can( 'set_' . $name )
412 then $name must be a many to many pseudo relation. And that in a
413 similarly ugly was I find out what is the ResultSource of objects from
414 that many to many pseudo relation.
421 =head2 recursive_update
423 The method that does the work here.
427 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
428 (pseudo) relation on $self.
430 =head2 get_m2m_source
432 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
433 to many (pseudo) relation 'name' from $self.
439 =head1 CONFIGURATION AND ENVIRONMENT
441 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
447 =head1 INCOMPATIBILITIES
449 =for author to fill in:
454 =head1 BUGS AND LIMITATIONS
456 =for author to fill in:
458 No bugs have been reported.
460 Please report any bugs or feature requests to
461 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
462 L<http://rt.cpan.org>.
467 Zbigniew Lukasiak C<< <zby@cpan.org> >>
468 Influenced by code by Pedro Melo.
470 =head1 LICENCE AND COPYRIGHT
472 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
474 This module is free software; you can redistribute it and/or
475 modify it under the same terms as Perl itself. See L<perlartistic>.
478 =head1 DISCLAIMER OF WARRANTY
480 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
481 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
482 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
483 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
484 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
485 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
486 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
487 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
488 NECESSARY SERVICING, REPAIR, OR CORRECTION.
490 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
491 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
492 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
493 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
494 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
495 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
496 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
497 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
498 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF