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