3 package DBIx
::Class
::ResultSet
::RecursiveUpdate
;
5 use version
; our $VERSION = qv
('0.008');
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;
113 # updating many_to_many
114 for my $name ( keys %$updates ) {
115 next if exists $columns{$name};
116 my $value = $updates->{$name};
118 if ( is_m2m
( $self, $name) ) {
119 my ($pk) = _get_pk_for_related
( $self, $name);
121 my $result_source = $object->$name->result_source;
123 if( ! defined $value ){
127 @updates = @{ $value };
130 @updates = ( $value );
132 for my $elem ( @updates ) {
134 push @rows, $result_source->resultset->find($elem);
138 $result_source->resultset->find( { $pk => $elem } );
141 my $set_meth = 'set_' . $name;
142 $object->$set_meth( \
@rows );
145 for my $name ( keys %post_updates ) {
146 my $info = $object->result_source->relationship_info($name);
147 _update_relation
( $self, $name, $updates, $object, $info, $if_not_submitted );
152 sub _get_columns_by_accessor
{
154 my $source = $self->result_source;
156 for my $name ( $source->columns ) {
157 my $info = $source->column_info($name);
158 $info->{name
} = $name;
159 $columns{ $info->{accessor
} || $name } = $info;
164 sub _update_relation
{
165 my ( $self, $name, $updates, $object, $info, $if_not_submitted ) = @_;
167 $self->related_resultset($name)->result_source->resultset;
169 if( $self->result_source->can( '_resolve_condition' ) ){
170 $resolved = $self->result_source->_resolve_condition( $info->{cond
}, $name, $object );
173 $resolved = $self->result_source->resolve_condition( $info->{cond
}, $name, $object );
176 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
178 if defined $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
&& $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
== $resolved;
179 if ( ref $updates->{$name} eq 'ARRAY' ) {
181 for my $sub_updates ( @{ $updates->{$name} } ) {
183 recursive_update
( resultset
=> $related_result, updates
=> $sub_updates, resolved
=> $resolved );
184 push @updated_ids, $sub_object->id;
186 my @related_pks = $related_result->result_source->primary_columns;
187 if( defined $if_not_submitted && $if_not_submitted eq 'delete' ){
188 if ( 1 == scalar @related_pks ){
189 $object->$name->search( { $related_pks[0] => { -not_in
=> \
@updated_ids } } )->delete;
192 elsif( defined $if_not_submitted && $if_not_submitted eq 'set_to_null' ){
193 if ( 1 == scalar @related_pks ){
194 my @fk = keys %$resolved;
195 $object->$name->search( { $related_pks[0] => { -not_in
=> \
@updated_ids } } )->update( { $fk[0] => undef } );
200 my $sub_updates = $updates->{$name};
202 if( ref $sub_updates ){
203 # for might_have relationship
204 if( $info->{attrs
}{accessor
} eq 'single' && defined $object->$name ){
205 $sub_object = recursive_update
(
206 resultset
=> $related_result,
207 updates
=> $sub_updates,
208 object
=> $object->$name
213 recursive_update
( resultset
=> $related_result, updates
=> $sub_updates, resolved
=> $resolved );
216 elsif( ! ref $sub_updates ){
217 $sub_object = $related_result->find( $sub_updates );
219 $object->set_from_related( $name, $sub_object );
224 my ( $self, $relation ) = @_;
225 my $rclass = $self->result_class;
227 # DBIx::Class::IntrospectableM2M
228 if ( $rclass->can('_m2m_metadata') ) {
229 return $rclass->_m2m_metadata->{$relation};
231 my $object = $self->new( {} );
232 if ( $object->can($relation)
233 and !$self->result_source->has_relationship($relation)
234 and $object->can( 'set_' . $relation ) )
242 my ( $self, $relation ) = @_;
243 my $rclass = $self->result_class;
245 # DBIx::Class::IntrospectableM2M
246 if ( $rclass->can('_m2m_metadata') ) {
247 return $self->result_source->related_source(
248 $rclass->_m2m_metadata->{$relation}{relation
} )
250 $rclass->_m2m_metadata->{$relation}{foreign_relation
} );
252 my $object = $self->new( {} );
253 my $r = $object->$relation;
254 return $r->result_source;
257 sub _delete_empty_auto_increment
{
258 my ( $self, $object ) = @_;
259 for my $col ( keys %{ $object->{_column_data
} } ) {
261 $object->result_source->column_info($col)->{is_auto_increment
}
262 and ( !defined $object->{_column_data
}{$col}
263 or $object->{_column_data
}{$col} eq '' )
266 delete $object->{_column_data
}{$col};
271 sub _get_pk_for_related
{
272 my ( $self, $relation ) = @_;
274 if ( $self->result_source->has_relationship($relation) ) {
275 $result_source = $self->result_source->related_source($relation);
279 if ( is_m2m
($self, $relation) ) {
280 $result_source = get_m2m_source
($self, $relation);
282 return $result_source->primary_columns;
285 sub _master_relation_cond
{
286 my ( $source, $cond, @foreign_ids ) = @_;
287 my $foreign_ids_re = join '|', @foreign_ids;
288 if ( ref $cond eq 'HASH' ) {
289 for my $f_key ( keys %{$cond} ) {
291 # might_have is not master
292 my $col = $cond->{$f_key};
294 if ( $source->column_info($col)->{is_auto_increment
} ) {
297 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
302 elsif ( ref $cond eq 'ARRAY' ) {
303 for my $new_cond (@$cond) {
305 if _master_relation_cond
( $source, $new_cond, @foreign_ids );
311 1; # Magic true value required at end of module
316 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
321 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.006
326 The functional interface:
328 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
329 resultset => $schema->resultset( 'Dvd' ),
334 title => 'One Flew Over the Cuckoo's Nest'
341 As ResultSet subclass:
343 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
345 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
349 my $user = $user_rs->recursive_update( {
353 title => 'One Flew Over the Cuckoo's Nest'
361 This is still experimental. I've added a functional interface so that it can be used
362 in Form Processors and not require modification of the model.
364 You can feed the ->create method with a recursive datastructure and have the related records
365 created. Unfortunately you cannot do a similar thing with update_or_create - this module
366 tries to fill that void.
368 It is a base class for ResultSets providing just one method: recursive_update
369 which works just like update_or_create but can recursively update or create
370 data objects composed of multiple rows. All rows need to be identified by primary keys
371 - so you need to provide them in the update structure (unless they can be deduced from
372 the parent row - for example when you have a belongs_to relationship).
373 If not all colums comprising the primary key are specified - then a new row will be created,
374 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
378 If the resultset itself stores an assignement for the primary key,
381 my $restricted_rs = $user_rs->search( { id => 1 } );
383 then you need to inform recursive_update about additional predicate with a second argument:
385 my $user = $restricted_rs->recursive_update( {
388 title => 'One Flew Over the Cuckoo's Nest'
395 This will work with a new DBIC release.
397 For a many_to_many (pseudo) relation you can supply a list of primary keys
398 from the other table - and it will link the record at hand to those and
399 only those records identified by them. This is convenient for handling web
400 forms with check boxes (or a SELECT box with multiple choice) that let you
401 update such (pseudo) relations.
403 For a description how to set up base classes for ResultSets see load_namespaces
404 in DBIx::Class::Schema.
406 =head1 DESIGN CHOICES
408 =head2 Treatment of many to many pseudo relations
410 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
411 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
412 if($object->can($name) and
413 !$object->result_source->has_relationship($name) and
414 $object->can( 'set_' . $name )
417 then $name must be a many to many pseudo relation. And that in a
418 similarly ugly was I find out what is the ResultSource of objects from
419 that many to many pseudo relation.
426 =head2 recursive_update
428 The method that does the work here.
432 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
433 (pseudo) relation on $self.
435 =head2 get_m2m_source
437 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
438 to many (pseudo) relation 'name' from $self.
444 =head1 CONFIGURATION AND ENVIRONMENT
446 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
452 =head1 INCOMPATIBILITIES
454 =for author to fill in:
459 =head1 BUGS AND LIMITATIONS
461 =for author to fill in:
463 No bugs have been reported.
465 Please report any bugs or feature requests to
466 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
467 L<http://rt.cpan.org>.
472 Zbigniew Lukasiak C<< <zby@cpan.org> >>
473 Influenced by code by Pedro Melo.
475 =head1 LICENCE AND COPYRIGHT
477 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
479 This module is free software; you can redistribute it and/or
480 modify it under the same terms as Perl itself. See L<perlartistic>.
483 =head1 DISCLAIMER OF WARRANTY
485 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
486 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
487 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
488 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
489 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
490 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
491 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
492 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
493 NECESSARY SERVICING, REPAIR, OR CORRECTION.
495 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
496 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
497 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
498 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
499 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
500 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
501 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
502 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
503 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF