3 package DBIx
::Class
::ResultSet
::RecursiveUpdate
;
5 use version
; our $VERSION = qv
('0.005');
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 ) = @params{ qw
/resultset updates fixed_fields object/ };
26 # warn 'entering: ' . $self->result_source->from();
27 carp
'fixed fields needs to be an array ref' if $fixed_fields && ref($fixed_fields) ne 'ARRAY';
29 %fixed_fields = map { $_ => 1 } @$fixed_fields if $fixed_fields;
30 if ( blessed
($updates) && $updates->isa('DBIx::Class::Row') ) {
33 # direct column accessors
36 # relations that that should be done before the row is inserted into the database
40 # relations that that should be done after the row is inserted into the database
41 # like has_many and might_have
43 my %columns_by_accessor = _get_columns_by_accessor
( $self );
45 for my $name ( keys %$updates ) {
46 my $source = $self->result_source;
47 if ( $columns_by_accessor{$name}
48 && !( $source->has_relationship($name) && ref( $updates->{$name} ) )
51 $columns{$name} = $updates->{$name};
54 next if !$source->has_relationship($name);
55 my $info = $source->relationship_info($name);
57 _master_relation_cond
(
58 $source, $info->{cond
}, _get_pk_for_related
( $self, $name)
62 $pre_updates{$name} = $updates->{$name};
65 $post_updates{$name} = $updates->{$name};
68 # warn 'columns: ' . Dumper( \%columns ); use Data::Dumper;
71 grep { !exists $columns{$_} && !exists $fixed_fields{$_} } $self->result_source->primary_columns;
72 if ( !$object && !scalar @missing ) {
73 $object = $self->find( \
%columns, { key
=> 'primary' } );
75 $object ||= $self->new( {} );
77 # first update columns and other accessors - so that later related records can be found
78 for my $name ( keys %columns ) {
79 $object->$name( $updates->{$name} );
81 for my $name ( keys %pre_updates ) {
82 my $info = $object->result_source->relationship_info($name);
83 _update_relation
( $self, $name, $updates, $object, $info );
85 # $self->_delete_empty_auto_increment($object);
86 # don't allow insert to recurse to related objects - we do the recursion ourselves
87 # $object->{_rel_in_storage} = 1;
88 $object->update_or_insert;
90 # updating many_to_many
91 for my $name ( keys %$updates ) {
92 next if exists $columns{$name};
93 my $value = $updates->{$name};
95 if ( is_m2m
( $self, $name) ) {
96 my ($pk) = _get_pk_for_related
( $self, $name);
98 my $result_source = $object->$name->result_source;
99 for my $elem ( @{ $updates->{$name} } ) {
101 push @rows, $result_source->resultset->find($elem);
105 $result_source->resultset->find( { $pk => $elem } );
108 my $set_meth = 'set_' . $name;
109 $object->$set_meth( \
@rows );
112 for my $name ( keys %post_updates ) {
113 my $info = $object->result_source->relationship_info($name);
114 _update_relation
( $self, $name, $updates, $object, $info );
119 sub _get_columns_by_accessor
{
121 my $source = $self->result_source;
123 for my $name ( $source->columns ) {
124 my $info = $source->column_info($name);
125 $info->{name
} = $name;
126 $columns{ $info->{accessor
} || $name } = $info;
131 sub _update_relation
{
132 my ( $self, $name, $updates, $object, $info ) = @_;
134 $self->related_resultset($name)->result_source->resultset;
136 $self->result_source->resolve_condition( $info->{cond
}, $name, $object );
138 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
140 if defined $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
&& $DBIx::Class
::ResultSource
::UNRESOLVABLE_CONDITION
== $resolved;
141 if ( ref $updates->{$name} eq 'ARRAY' ) {
142 for my $sub_updates ( @{ $updates->{$name} } ) {
143 $sub_updates = { %$sub_updates, %$resolved } if $resolved && ref( $sub_updates ) eq 'HASH';
145 recursive_update
( resultset
=> $related_result, updates
=> $sub_updates );
149 my $sub_updates = $updates->{$name};
150 $sub_updates = { %$sub_updates, %$resolved } if $resolved && ref( $sub_updates ) eq 'HASH';
152 if( $info->{attrs
}{accessor
} eq 'single' && defined $object->$name ){
153 $sub_object = recursive_update
(
154 resultset
=> $related_result,
155 updates
=> $sub_updates,
156 object
=> $object->$name
161 recursive_update
( resultset
=> $related_result, updates
=> $sub_updates );
163 $object->set_from_related( $name, $sub_object );
168 my ( $self, $relation ) = @_;
169 my $rclass = $self->result_class;
171 # DBIx::Class::IntrospectableM2M
172 if ( $rclass->can('_m2m_metadata') ) {
173 return $rclass->_m2m_metadata->{$relation};
175 my $object = $self->new( {} );
176 if ( $object->can($relation)
177 and !$self->result_source->has_relationship($relation)
178 and $object->can( 'set_' . $relation ) )
186 my ( $self, $relation ) = @_;
187 my $rclass = $self->result_class;
189 # DBIx::Class::IntrospectableM2M
190 if ( $rclass->can('_m2m_metadata') ) {
191 return $self->result_source->related_source(
192 $rclass->_m2m_metadata->{$relation}{relation
} )
194 $rclass->_m2m_metadata->{$relation}{foreign_relation
} );
196 my $object = $self->new( {} );
197 my $r = $object->$relation;
198 return $r->result_source;
201 sub _delete_empty_auto_increment
{
202 my ( $self, $object ) = @_;
203 for my $col ( keys %{ $object->{_column_data
} } ) {
205 $object->result_source->column_info($col)->{is_auto_increment
}
206 and ( !defined $object->{_column_data
}{$col}
207 or $object->{_column_data
}{$col} eq '' )
210 delete $object->{_column_data
}{$col};
215 sub _get_pk_for_related
{
216 my ( $self, $relation ) = @_;
218 if ( $self->result_source->has_relationship($relation) ) {
219 $result_source = $self->result_source->related_source($relation);
223 if ( is_m2m
($self, $relation) ) {
224 $result_source = get_m2m_source
($self, $relation);
226 return $result_source->primary_columns;
229 sub _master_relation_cond
{
230 my ( $source, $cond, @foreign_ids ) = @_;
231 my $foreign_ids_re = join '|', @foreign_ids;
232 if ( ref $cond eq 'HASH' ) {
233 for my $f_key ( keys %{$cond} ) {
235 # might_have is not master
236 my $col = $cond->{$f_key};
238 if ( $source->column_info($col)->{is_auto_increment
} ) {
241 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
246 elsif ( ref $cond eq 'ARRAY' ) {
247 for my $new_cond (@$cond) {
249 if _master_relation_cond
( $source, $new_cond, @foreign_ids );
255 1; # Magic true value required at end of module
260 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
265 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.004
270 The functional interface:
272 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
276 title => 'One Flew Over the Cuckoo's Nest'
283 As ResultSet subclass:
285 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
287 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
291 my $user = $user_rs->recursive_update( {
295 title => 'One Flew Over the Cuckoo's Nest'
303 This is still experimental. I've added a functional interface so that it can be used
304 in Form Processors and not require modification of the model.
306 You can feed the ->create method with a recursive datastructure and have the related records
307 created. Unfortunately you cannot do a similar thing with update_or_create - this module
308 tries to fill that void.
310 It is a base class for ResultSets providing just one method: recursive_update
311 which works just like update_or_create but can recursively update or create
312 data objects composed of multiple rows. All rows need to be identified by primary keys
313 - so you need to provide them in the update structure (unless they can be deduced from
314 the parent row - for example when you have a belongs_to relationship).
315 If not all colums comprising the primary key are specified - then a new row will be created,
316 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
320 If the resultset itself stores an assignement for the primary key,
323 my $restricted_rs = $user_rs->search( { id => 1 } );
325 then you need to inform recursive_update about additional predicate with a second argument:
327 my $user = $restricted_rs->recursive_update( {
330 title => 'One Flew Over the Cuckoo's Nest'
337 This will work with a new DBIC release.
339 For a many_to_many (pseudo) relation you can supply a list of primary keys
340 from the other table - and it will link the record at hand to those and
341 only those records identified by them. This is convenient for handling web
342 forms with check boxes (or a SELECT box with multiple choice) that let you
343 update such (pseudo) relations.
345 For a description how to set up base classes for ResultSets see load_namespaces
346 in DBIx::Class::Schema.
348 =head1 DESIGN CHOICES
350 =head2 Treatment of many to many pseudo relations
352 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
353 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
354 if($object->can($name) and
355 !$object->result_source->has_relationship($name) and
356 $object->can( 'set_' . $name )
359 then $name must be a many to many pseudo relation. And that in a
360 similarly ugly was I find out what is the ResultSource of objects from
361 that many to many pseudo relation.
368 =head2 recursive_update
370 The method that does the work here.
374 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
375 (pseudo) relation on $self.
377 =head2 get_m2m_source
379 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
380 to many (pseudo) relation 'name' from $self.
386 =head1 CONFIGURATION AND ENVIRONMENT
388 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
394 =head1 INCOMPATIBILITIES
396 =for author to fill in:
401 =head1 BUGS AND LIMITATIONS
403 =for author to fill in:
405 No bugs have been reported.
407 Please report any bugs or feature requests to
408 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
409 L<http://rt.cpan.org>.
414 Zbigniew Lukasiak C<< <zby@cpan.org> >>
415 Influenced by code by Pedro Melo.
417 =head1 LICENCE AND COPYRIGHT
419 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
421 This module is free software; you can redistribute it and/or
422 modify it under the same terms as Perl itself. See L<perlartistic>.
425 =head1 DISCLAIMER OF WARRANTY
427 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
428 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
429 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
430 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
431 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
432 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
433 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
434 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
435 NECESSARY SERVICING, REPAIR, OR CORRECTION.
437 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
438 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
439 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
440 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
441 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
442 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
443 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
444 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
445 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF