3 package DBIx
::Class
::ResultSet
::RecursiveUpdate
;
5 our $VERSION = '0.012';
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 && ($info->{attrs
}{join_type
} eq 'LEFT'));
219 $object->set_from_related( $name, $sub_object )
220 unless (!$sub_object && !$sub_updates && ($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
322 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.006
327 The functional interface:
329 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
330 resultset => $schema->resultset( 'Dvd' ),
335 title => 'One Flew Over the Cuckoo's Nest'
342 As ResultSet subclass:
344 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
346 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
350 my $user = $user_rs->recursive_update( {
354 title => 'One Flew Over the Cuckoo's Nest'
362 This is still experimental. I've added a functional interface so that it can be used
363 in Form Processors and not require modification of the model.
365 You can feed the ->create method with a recursive datastructure and have the related records
366 created. Unfortunately you cannot do a similar thing with update_or_create - this module
367 tries to fill that void.
369 It is a base class for ResultSets providing just one method: recursive_update
370 which works just like update_or_create but can recursively update or create
371 data objects composed of multiple rows. All rows need to be identified by primary keys
372 - so you need to provide them in the update structure (unless they can be deduced from
373 the parent row - for example when you have a belongs_to relationship).
374 If not all colums comprising the primary key are specified - then a new row will be created,
375 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
379 If the resultset itself stores an assignement for the primary key,
382 my $restricted_rs = $user_rs->search( { id => 1 } );
384 then you need to inform recursive_update about additional predicate with a second argument:
386 my $user = $restricted_rs->recursive_update( {
389 title => 'One Flew Over the Cuckoo's Nest'
396 This will work with a new DBIC release.
398 For a many_to_many (pseudo) relation you can supply a list of primary keys
399 from the other table - and it will link the record at hand to those and
400 only those records identified by them. This is convenient for handling web
401 forms with check boxes (or a SELECT box with multiple choice) that let you
402 update such (pseudo) relations.
404 For a description how to set up base classes for ResultSets see load_namespaces
405 in DBIx::Class::Schema.
407 =head1 DESIGN CHOICES
409 =head2 Treatment of many to many pseudo relations
411 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
412 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
413 if($object->can($name) and
414 !$object->result_source->has_relationship($name) and
415 $object->can( 'set_' . $name )
418 then $name must be a many to many pseudo relation. And that in a
419 similarly ugly was I find out what is the ResultSource of objects from
420 that many to many pseudo relation.
427 =head2 recursive_update
429 The method that does the work here.
433 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
434 (pseudo) relation on $self.
436 =head2 get_m2m_source
438 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
439 to many (pseudo) relation 'name' from $self.
445 =head1 CONFIGURATION AND ENVIRONMENT
447 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
453 =head1 INCOMPATIBILITIES
455 =for author to fill in:
460 =head1 BUGS AND LIMITATIONS
462 =for author to fill in:
464 No bugs have been reported.
466 Please report any bugs or feature requests to
467 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
468 L<http://rt.cpan.org>.
473 Zbigniew Lukasiak C<< <zby@cpan.org> >>
474 Influenced by code by Pedro Melo.
476 =head1 LICENCE AND COPYRIGHT
478 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
480 This module is free software; you can redistribute it and/or
481 modify it under the same terms as Perl itself. See L<perlartistic>.
484 =head1 DISCLAIMER OF WARRANTY
486 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
487 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
488 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
489 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
490 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
491 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
492 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
493 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
494 NECESSARY SERVICING, REPAIR, OR CORRECTION.
496 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
497 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
498 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
499 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
500 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
501 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
502 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
503 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
504 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF