test case for might_have and another minor bug fix
[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 our $VERSION = '0.012';
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, $if_not_submitted ) = @params{ qw/resultset updates fixed_fields object resolved if_not_submitted/ };
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 # warn 'finding by: ' . Dumper( $updates ); use Data::Dumper;
41 $object = $self->find( $updates, { key => 'primary' } );
42 }
43 $updates = { %$updates, %$resolved };
44 @missing =
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' } );
49 }
50 $object ||= $self->new( {} );
51 # warn Dumper( $updates ); use Data::Dumper;
52 # direct column accessors
53 my %columns;
54
55 # relations that that should be done before the row is inserted into the database
56 # like belongs_to
57 my %pre_updates;
58
59 # relations that that should be done after the row is inserted into the database
60 # like has_many and might_have
61 my %post_updates;
62 my %other_methods;
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} ) )
71 )
72 {
73 $columns{$name} = $updates->{$name};
74 next;
75 }
76 if( !( $source->has_relationship($name) ) ){
77 $other_methods{$name} = $updates->{$name};
78 next;
79 }
80 my $info = $source->relationship_info($name);
81 if (
82 _master_relation_cond(
83 $source, $info->{cond}, _get_pk_for_related( $self, $name)
84 )
85 )
86 {
87 $pre_updates{$name} = $updates->{$name};
88 }
89 else {
90 $post_updates{$name} = $updates->{$name};
91 }
92 }
93 # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
94
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} );
98 }
99 for my $name ( keys %other_methods) {
100 $object->$name( $updates->{$name} ) if $object->can( $name );
101 }
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 );
105 }
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;
109
110 $object->update_or_insert if $object->is_changed;
111
112 # updating many_to_many
113 for my $name ( keys %$updates ) {
114 next if exists $columns{$name};
115 my $value = $updates->{$name};
116
117 if ( is_m2m( $self, $name) ) {
118 my ($pk) = _get_pk_for_related( $self, $name);
119 my @rows;
120 my $result_source = $object->$name->result_source;
121 my @updates;
122 if( ! defined $value ){
123 next;
124 }
125 elsif( ref $value ){
126 @updates = @{ $value };
127 }
128 else{
129 @updates = ( $value );
130 }
131 for my $elem ( @updates ) {
132 if ( ref $elem ) {
133 push @rows, recursive_update( resultset => $result_source->resultset, updates => $elem );
134 }
135 else {
136 push @rows,
137 $result_source->resultset->find( { $pk => $elem } );
138 }
139 }
140 my $set_meth = 'set_' . $name;
141 $object->$set_meth( \@rows );
142 }
143 }
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 );
147 }
148 return $object;
149 }
150
151 sub _get_columns_by_accessor {
152 my $self = shift;
153 my $source = $self->result_source;
154 my %columns;
155 for my $name ( $source->columns ) {
156 my $info = $source->column_info($name);
157 $info->{name} = $name;
158 $columns{ $info->{accessor} || $name } = $info;
159 }
160 return %columns;
161 }
162
163 sub _update_relation {
164 my ( $self, $name, $updates, $object, $info, $if_not_submitted ) = @_;
165 my $related_result =
166 $self->related_resultset($name)->result_source->resultset;
167 my $resolved;
168 if( $self->result_source->can( '_resolve_condition' ) ){
169 $resolved = $self->result_source->_resolve_condition( $info->{cond}, $name, $object );
170 }
171 else{
172 $resolved = $self->result_source->resolve_condition( $info->{cond}, $name, $object );
173 }
174
175 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
176 $resolved = {}
177 if defined $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION && $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION == $resolved;
178 if ( ref $updates->{$name} eq 'ARRAY' ) {
179 my @updated_ids;
180 for my $sub_updates ( @{ $updates->{$name} } ) {
181 my $sub_object =
182 recursive_update( resultset => $related_result, updates => $sub_updates, resolved => $resolved );
183 push @updated_ids, $sub_object->id;
184 }
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;
189 }
190 }
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 } );
195 }
196 }
197 }
198 else {
199 my $sub_updates = $updates->{$name};
200 my $sub_object;
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
208 );
209 }
210 else{
211 $sub_object =
212 recursive_update( resultset => $related_result, updates => $sub_updates, resolved => $resolved );
213 }
214 }
215 elsif( ! ref $sub_updates ){
216 $sub_object = $related_result->find( $sub_updates )
217 unless (!$sub_updates && ($info->{attrs}{join_type} eq 'LEFT'));
218 }
219 $object->set_from_related( $name, $sub_object )
220 unless (!$sub_object && !$sub_updates && ($info->{attrs}{join_type} eq 'LEFT'));
221 }
222 }
223
224 sub is_m2m {
225 my ( $self, $relation ) = @_;
226 my $rclass = $self->result_class;
227
228 # DBIx::Class::IntrospectableM2M
229 if ( $rclass->can('_m2m_metadata') ) {
230 return $rclass->_m2m_metadata->{$relation};
231 }
232 my $object = $self->new( {} );
233 if ( $object->can($relation)
234 and !$self->result_source->has_relationship($relation)
235 and $object->can( 'set_' . $relation ) )
236 {
237 return 1;
238 }
239 return;
240 }
241
242 sub get_m2m_source {
243 my ( $self, $relation ) = @_;
244 my $rclass = $self->result_class;
245
246 # DBIx::Class::IntrospectableM2M
247 if ( $rclass->can('_m2m_metadata') ) {
248 return $self->result_source->related_source(
249 $rclass->_m2m_metadata->{$relation}{relation} )
250 ->related_source(
251 $rclass->_m2m_metadata->{$relation}{foreign_relation} );
252 }
253 my $object = $self->new( {} );
254 my $r = $object->$relation;
255 return $r->result_source;
256 }
257
258 sub _delete_empty_auto_increment {
259 my ( $self, $object ) = @_;
260 for my $col ( keys %{ $object->{_column_data} } ) {
261 if (
262 $object->result_source->column_info($col)->{is_auto_increment}
263 and ( !defined $object->{_column_data}{$col}
264 or $object->{_column_data}{$col} eq '' )
265 )
266 {
267 delete $object->{_column_data}{$col};
268 }
269 }
270 }
271
272 sub _get_pk_for_related {
273 my ( $self, $relation ) = @_;
274 my $result_source;
275 if ( $self->result_source->has_relationship($relation) ) {
276 $result_source = $self->result_source->related_source($relation);
277 }
278
279 # many to many case
280 if ( is_m2m($self, $relation) ) {
281 $result_source = get_m2m_source($self, $relation);
282 }
283 return $result_source->primary_columns;
284 }
285
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} ) {
291
292 # might_have is not master
293 my $col = $cond->{$f_key};
294 $col =~ s/self\.//;
295 if ( $source->column_info($col)->{is_auto_increment} ) {
296 return 0;
297 }
298 if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
299 return 1;
300 }
301 }
302 }
303 elsif ( ref $cond eq 'ARRAY' ) {
304 for my $new_cond (@$cond) {
305 return 1
306 if _master_relation_cond( $source, $new_cond, @foreign_ids );
307 }
308 }
309 return;
310 }
311
312 1; # Magic true value required at end of module
313 __END__
314
315 =head1 NAME
316
317 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
318
319
320 =head1 VERSION
321
322 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.006
323
324
325 =head1 SYNOPSIS
326
327 The functional interface:
328
329 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
330 resultset => $schema->resultset( 'Dvd' ),
331 updates => {
332 id => 1,
333 owned_dvds => [
334 {
335 title => 'One Flew Over the Cuckoo's Nest'
336 }
337 ]
338 }
339 });
340
341
342 As ResultSet subclass:
343
344 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
345
346 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
347
348 Then:
349
350 my $user = $user_rs->recursive_update( {
351 id => 1,
352 owned_dvds => [
353 {
354 title => 'One Flew Over the Cuckoo's Nest'
355 }
356 ]
357 }
358 );
359
360
361 =head1 DESCRIPTION
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.
364
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.
368
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
376 primary keys).
377
378
379 If the resultset itself stores an assignement for the primary key,
380 like in the case of:
381
382 my $restricted_rs = $user_rs->search( { id => 1 } );
383
384 then you need to inform recursive_update about additional predicate with a second argument:
385
386 my $user = $restricted_rs->recursive_update( {
387 owned_dvds => [
388 {
389 title => 'One Flew Over the Cuckoo's Nest'
390 }
391 ]
392 },
393 [ 'id' ]
394 );
395
396 This will work with a new DBIC release.
397
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.
403
404 For a description how to set up base classes for ResultSets see load_namespaces
405 in DBIx::Class::Schema.
406
407 =head1 DESIGN CHOICES
408
409 =head2 Treatment of many to many pseudo relations
410
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 )
416 )
417
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.
421
422
423 =head1 INTERFACE
424
425 =head1 METHODS
426
427 =head2 recursive_update
428
429 The method that does the work here.
430
431 =head2 is_m2m
432
433 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
434 (pseudo) relation on $self.
435
436 =head2 get_m2m_source
437
438 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
439 to many (pseudo) relation 'name' from $self.
440
441
442 =head1 DIAGNOSTICS
443
444
445 =head1 CONFIGURATION AND ENVIRONMENT
446
447 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
448
449 =head1 DEPENDENCIES
450
451 DBIx::Class
452
453 =head1 INCOMPATIBILITIES
454
455 =for author to fill in:
456
457 None reported.
458
459
460 =head1 BUGS AND LIMITATIONS
461
462 =for author to fill in:
463
464 No bugs have been reported.
465
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>.
469
470
471 =head1 AUTHOR
472
473 Zbigniew Lukasiak C<< <zby@cpan.org> >>
474 Influenced by code by Pedro Melo.
475
476 =head1 LICENCE AND COPYRIGHT
477
478 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
479
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>.
482
483
484 =head1 DISCLAIMER OF WARRANTY
485
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.
495
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
505 SUCH DAMAGES.
This page took 0.069547 seconds and 4 git commands to generate.