fcbad3bbf816ea9fe858d1b83d3343dbaa2079dd
[chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate] / lib / DBIx / Class / ResultSet / RecursiveUpdate.pm
1 use strict;
2 use warnings;
3 package DBIx::Class::ResultSet::RecursiveUpdate;
4
5 use version; our $VERSION = qv('0.008');
6
7 use base qw(DBIx::Class::ResultSet);
8
9 sub recursive_update {
10 my ( $self, $updates, $fixed_fields ) = @_;
11 return DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update(
12 resultset => $self,
13 updates => $updates,
14 fixed_fields => $fixed_fields
15 );
16 }
17
18 package DBIx::Class::ResultSet::RecursiveUpdate::Functions;
19 use Carp;
20 use Scalar::Util qw( blessed );
21
22
23 sub recursive_update {
24 my %params = @_;
25 my ( $self, $updates, $fixed_fields, $object, $resolved ) = @params{ qw/resultset updates fixed_fields object resolved/ };
26 $resolved ||= {};
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';
29 my %fixed_fields;
30 %fixed_fields = map { $_ => 1 } @$fixed_fields if $fixed_fields;
31 if ( blessed($updates) && $updates->isa('DBIx::Class::Row') ) {
32 return $updates;
33 }
34 if ( $updates->{id} ){
35 $object = $self->find( $updates->{id}, { key => 'primary' } );
36 }
37 my @missing =
38 grep { !exists $updates->{$_} && !exists $fixed_fields{$_} } $self->result_source->primary_columns;
39 if ( !$object && !scalar @missing ) {
40 $object = $self->find( $updates, { key => 'primary' } );
41 }
42 @missing =
43 grep { !exists $resolved->{$_} } @missing;
44 if ( !$object && !scalar @missing ) {
45 $object = $self->find( \%{ %$updates, %$resolved }, { key => 'primary' } );
46 }
47 $object ||= $self->new( {} );
48 # warn Dumper( $updates ); use Data::Dumper;
49 # direct column accessors
50 my %columns;
51
52 # relations that that should be done before the row is inserted into the database
53 # like belongs_to
54 my %pre_updates;
55
56 # relations that that should be done after the row is inserted into the database
57 # like has_many and might_have
58 my %post_updates;
59 my %other_methods;
60 my %columns_by_accessor = _get_columns_by_accessor( $self );
61 # warn 'resolved: ' . Dumper( $resolved );
62 $updates = { %$updates, %$resolved };
63 # warn 'updates: ' . Dumper( $updates ); use Data::Dumper;
64 # warn 'columns: ' . Dumper( \%columns_by_accessor );
65 for my $name ( keys %$updates ) {
66 my $source = $self->result_source;
67 if ( $columns_by_accessor{$name}
68 && !( $source->has_relationship($name) && ref( $updates->{$name} ) )
69 )
70 {
71 $columns{$name} = $updates->{$name};
72 next;
73 }
74 if( !( $source->has_relationship($name) ) ){
75 $other_methods{$name} = $updates->{$name};
76 next;
77 }
78 my $info = $source->relationship_info($name);
79 if (
80 _master_relation_cond(
81 $source, $info->{cond}, _get_pk_for_related( $self, $name)
82 )
83 )
84 {
85 $pre_updates{$name} = $updates->{$name};
86 }
87 else {
88 $post_updates{$name} = $updates->{$name};
89 }
90 }
91 # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
92
93 # first update columns and other accessors - so that later related records can be found
94 for my $name ( keys %columns ) {
95 $object->$name( $columns{$name} );
96 }
97 for my $name ( keys %other_methods) {
98 $object->$name( $updates->{$name} ) if $object->can( $name );
99 }
100 for my $name ( keys %pre_updates ) {
101 my $info = $object->result_source->relationship_info($name);
102 _update_relation( $self, $name, $updates, $object, $info );
103 }
104 # $self->_delete_empty_auto_increment($object);
105 # don't allow insert to recurse to related objects - we do the recursion ourselves
106 # $object->{_rel_in_storage} = 1;
107
108 $object->update_or_insert;
109
110
111 # updating many_to_many
112 for my $name ( keys %$updates ) {
113 next if exists $columns{$name};
114 my $value = $updates->{$name};
115
116 if ( is_m2m( $self, $name) ) {
117 my ($pk) = _get_pk_for_related( $self, $name);
118 my @rows;
119 my $result_source = $object->$name->result_source;
120 my @updates;
121 if( ! defined $value ){
122 next;
123 }
124 elsif( ref $value ){
125 @updates = @{ $value };
126 }
127 else{
128 @updates = ( $value );
129 }
130 for my $elem ( @updates ) {
131 if ( ref $elem ) {
132 push @rows, $result_source->resultset->find($elem);
133 }
134 else {
135 push @rows,
136 $result_source->resultset->find( { $pk => $elem } );
137 }
138 }
139 my $set_meth = 'set_' . $name;
140 $object->$set_meth( \@rows );
141 }
142 }
143 for my $name ( keys %post_updates ) {
144 my $info = $object->result_source->relationship_info($name);
145 _update_relation( $self, $name, $updates, $object, $info );
146 }
147 return $object;
148 }
149
150 sub _get_columns_by_accessor {
151 my $self = shift;
152 my $source = $self->result_source;
153 my %columns;
154 for my $name ( $source->columns ) {
155 my $info = $source->column_info($name);
156 $info->{name} = $name;
157 $columns{ $info->{accessor} || $name } = $info;
158 }
159 return %columns;
160 }
161
162 sub _update_relation {
163 my ( $self, $name, $updates, $object, $info ) = @_;
164 my $related_result =
165 $self->related_resultset($name)->result_source->resultset;
166 my $resolved;
167 if( $self->result_source->can( '_resolve_condition' ) ){
168 $resolved = $self->result_source->_resolve_condition( $info->{cond}, $name, $object );
169 }
170 else{
171 $resolved = $self->result_source->resolve_condition( $info->{cond}, $name, $object );
172 }
173
174 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
175 $resolved = {}
176 if defined $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION && $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION == $resolved;
177 if ( ref $updates->{$name} eq 'ARRAY' ) {
178 for my $sub_updates ( @{ $updates->{$name} } ) {
179 my $sub_object =
180 recursive_update( resultset => $related_result, updates => $sub_updates, resolved => $resolved );
181 }
182 }
183 else {
184 my $sub_updates = $updates->{$name};
185 my $sub_object;
186 if( ref $sub_updates ){
187 # for might_have relationship
188 if( $info->{attrs}{accessor} eq 'single' && defined $object->$name ){
189 $sub_object = recursive_update(
190 resultset => $related_result,
191 updates => $sub_updates,
192 object => $object->$name
193 );
194 }
195 else{
196 $sub_object =
197 recursive_update( resultset => $related_result, updates => $sub_updates, resolved => $resolved );
198 }
199 }
200 elsif( ! ref $sub_updates ){
201 $sub_object = $related_result->find( $sub_updates );
202 }
203 $object->set_from_related( $name, $sub_object );
204 }
205 }
206
207 sub is_m2m {
208 my ( $self, $relation ) = @_;
209 my $rclass = $self->result_class;
210
211 # DBIx::Class::IntrospectableM2M
212 if ( $rclass->can('_m2m_metadata') ) {
213 return $rclass->_m2m_metadata->{$relation};
214 }
215 my $object = $self->new( {} );
216 if ( $object->can($relation)
217 and !$self->result_source->has_relationship($relation)
218 and $object->can( 'set_' . $relation ) )
219 {
220 return 1;
221 }
222 return;
223 }
224
225 sub get_m2m_source {
226 my ( $self, $relation ) = @_;
227 my $rclass = $self->result_class;
228
229 # DBIx::Class::IntrospectableM2M
230 if ( $rclass->can('_m2m_metadata') ) {
231 return $self->result_source->related_source(
232 $rclass->_m2m_metadata->{$relation}{relation} )
233 ->related_source(
234 $rclass->_m2m_metadata->{$relation}{foreign_relation} );
235 }
236 my $object = $self->new( {} );
237 my $r = $object->$relation;
238 return $r->result_source;
239 }
240
241 sub _delete_empty_auto_increment {
242 my ( $self, $object ) = @_;
243 for my $col ( keys %{ $object->{_column_data} } ) {
244 if (
245 $object->result_source->column_info($col)->{is_auto_increment}
246 and ( !defined $object->{_column_data}{$col}
247 or $object->{_column_data}{$col} eq '' )
248 )
249 {
250 delete $object->{_column_data}{$col};
251 }
252 }
253 }
254
255 sub _get_pk_for_related {
256 my ( $self, $relation ) = @_;
257 my $result_source;
258 if ( $self->result_source->has_relationship($relation) ) {
259 $result_source = $self->result_source->related_source($relation);
260 }
261
262 # many to many case
263 if ( is_m2m($self, $relation) ) {
264 $result_source = get_m2m_source($self, $relation);
265 }
266 return $result_source->primary_columns;
267 }
268
269 sub _master_relation_cond {
270 my ( $source, $cond, @foreign_ids ) = @_;
271 my $foreign_ids_re = join '|', @foreign_ids;
272 if ( ref $cond eq 'HASH' ) {
273 for my $f_key ( keys %{$cond} ) {
274
275 # might_have is not master
276 my $col = $cond->{$f_key};
277 $col =~ s/self\.//;
278 if ( $source->column_info($col)->{is_auto_increment} ) {
279 return 0;
280 }
281 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
282 return 1;
283 }
284 }
285 }
286 elsif ( ref $cond eq 'ARRAY' ) {
287 for my $new_cond (@$cond) {
288 return 1
289 if _master_relation_cond( $source, $new_cond, @foreign_ids );
290 }
291 }
292 return;
293 }
294
295 1; # Magic true value required at end of module
296 __END__
297
298 =head1 NAME
299
300 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
301
302
303 =head1 VERSION
304
305 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.006
306
307
308 =head1 SYNOPSIS
309
310 The functional interface:
311
312 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
313 resultset => $schema->resultset( 'Dvd' ),
314 updates => {
315 id => 1,
316 owned_dvds => [
317 {
318 title => 'One Flew Over the Cuckoo's Nest'
319 }
320 ]
321 }
322 });
323
324
325 As ResultSet subclass:
326
327 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
328
329 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
330
331 Then:
332
333 my $user = $user_rs->recursive_update( {
334 id => 1,
335 owned_dvds => [
336 {
337 title => 'One Flew Over the Cuckoo's Nest'
338 }
339 ]
340 }
341 );
342
343
344 =head1 DESCRIPTION
345 This is still experimental. I've added a functional interface so that it can be used
346 in Form Processors and not require modification of the model.
347
348 You can feed the ->create method with a recursive datastructure and have the related records
349 created. Unfortunately you cannot do a similar thing with update_or_create - this module
350 tries to fill that void.
351
352 It is a base class for ResultSets providing just one method: recursive_update
353 which works just like update_or_create but can recursively update or create
354 data objects composed of multiple rows. All rows need to be identified by primary keys
355 - so you need to provide them in the update structure (unless they can be deduced from
356 the parent row - for example when you have a belongs_to relationship).
357 If not all colums comprising the primary key are specified - then a new row will be created,
358 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
359 primary keys).
360
361
362 If the resultset itself stores an assignement for the primary key,
363 like in the case of:
364
365 my $restricted_rs = $user_rs->search( { id => 1 } );
366
367 then you need to inform recursive_update about additional predicate with a second argument:
368
369 my $user = $restricted_rs->recursive_update( {
370 owned_dvds => [
371 {
372 title => 'One Flew Over the Cuckoo's Nest'
373 }
374 ]
375 },
376 [ 'id' ]
377 );
378
379 This will work with a new DBIC release.
380
381 For a many_to_many (pseudo) relation you can supply a list of primary keys
382 from the other table - and it will link the record at hand to those and
383 only those records identified by them. This is convenient for handling web
384 forms with check boxes (or a SELECT box with multiple choice) that let you
385 update such (pseudo) relations.
386
387 For a description how to set up base classes for ResultSets see load_namespaces
388 in DBIx::Class::Schema.
389
390 =head1 DESIGN CHOICES
391
392 =head2 Treatment of many to many pseudo relations
393
394 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
395 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
396 if($object->can($name) and
397 !$object->result_source->has_relationship($name) and
398 $object->can( 'set_' . $name )
399 )
400
401 then $name must be a many to many pseudo relation. And that in a
402 similarly ugly was I find out what is the ResultSource of objects from
403 that many to many pseudo relation.
404
405
406 =head1 INTERFACE
407
408 =head1 METHODS
409
410 =head2 recursive_update
411
412 The method that does the work here.
413
414 =head2 is_m2m
415
416 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
417 (pseudo) relation on $self.
418
419 =head2 get_m2m_source
420
421 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
422 to many (pseudo) relation 'name' from $self.
423
424
425 =head1 DIAGNOSTICS
426
427
428 =head1 CONFIGURATION AND ENVIRONMENT
429
430 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
431
432 =head1 DEPENDENCIES
433
434 DBIx::Class
435
436 =head1 INCOMPATIBILITIES
437
438 =for author to fill in:
439
440 None reported.
441
442
443 =head1 BUGS AND LIMITATIONS
444
445 =for author to fill in:
446
447 No bugs have been reported.
448
449 Please report any bugs or feature requests to
450 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
451 L<http://rt.cpan.org>.
452
453
454 =head1 AUTHOR
455
456 Zbigniew Lukasiak C<< <zby@cpan.org> >>
457 Influenced by code by Pedro Melo.
458
459 =head1 LICENCE AND COPYRIGHT
460
461 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
462
463 This module is free software; you can redistribute it and/or
464 modify it under the same terms as Perl itself. See L<perlartistic>.
465
466
467 =head1 DISCLAIMER OF WARRANTY
468
469 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
470 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
471 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
472 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
473 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
474 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
475 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
476 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
477 NECESSARY SERVICING, REPAIR, OR CORRECTION.
478
479 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
480 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
481 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
482 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
483 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
484 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
485 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
486 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
487 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
488 SUCH DAMAGES.
This page took 0.072139 seconds and 4 git commands to generate.