avoid uninitialized string warnings
[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.013';
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 && (exists $info->{attrs}{join_type} && $info->{attrs}{join_type} eq 'LEFT'));
218 }
219 $object->set_from_related( $name, $sub_object )
220 unless (!$sub_object && !$sub_updates && (exists $info->{attrs}{join_type} && $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 =head1 SYNOPSIS
320
321 The functional interface:
322
323 my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
324 resultset => $schema->resultset( 'Dvd' ),
325 updates => {
326 id => 1,
327 owned_dvds => [
328 {
329 title => 'One Flew Over the Cuckoo's Nest'
330 }
331 ]
332 }
333 });
334
335
336 As ResultSet subclass:
337
338 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
339
340 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
341
342 Then:
343
344 my $user = $user_rs->recursive_update( {
345 id => 1,
346 owned_dvds => [
347 {
348 title => 'One Flew Over the Cuckoo's Nest'
349 }
350 ]
351 }
352 );
353
354
355 =head1 DESCRIPTION
356 This is still experimental. I've added a functional interface so that it can be used
357 in Form Processors and not require modification of the model.
358
359 You can feed the ->create method with a recursive datastructure and have the related records
360 created. Unfortunately you cannot do a similar thing with update_or_create - this module
361 tries to fill that void.
362
363 It is a base class for ResultSets providing just one method: recursive_update
364 which works just like update_or_create but can recursively update or create
365 data objects composed of multiple rows. All rows need to be identified by primary keys
366 - so you need to provide them in the update structure (unless they can be deduced from
367 the parent row - for example when you have a belongs_to relationship).
368 If not all colums comprising the primary key are specified - then a new row will be created,
369 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
370 primary keys).
371
372
373 If the resultset itself stores an assignement for the primary key,
374 like in the case of:
375
376 my $restricted_rs = $user_rs->search( { id => 1 } );
377
378 then you need to inform recursive_update about additional predicate with a second argument:
379
380 my $user = $restricted_rs->recursive_update( {
381 owned_dvds => [
382 {
383 title => 'One Flew Over the Cuckoo's Nest'
384 }
385 ]
386 },
387 [ 'id' ]
388 );
389
390 This will work with a new DBIC release.
391
392 For a many_to_many (pseudo) relation you can supply a list of primary keys
393 from the other table - and it will link the record at hand to those and
394 only those records identified by them. This is convenient for handling web
395 forms with check boxes (or a SELECT box with multiple choice) that let you
396 update such (pseudo) relations.
397
398 For a description how to set up base classes for ResultSets see load_namespaces
399 in DBIx::Class::Schema.
400
401 =head1 DESIGN CHOICES
402
403 =head2 Treatment of many to many pseudo relations
404
405 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
406 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
407 if($object->can($name) and
408 !$object->result_source->has_relationship($name) and
409 $object->can( 'set_' . $name )
410 )
411
412 then $name must be a many to many pseudo relation. And that in a
413 similarly ugly was I find out what is the ResultSource of objects from
414 that many to many pseudo relation.
415
416
417 =head1 INTERFACE
418
419 =head1 METHODS
420
421 =head2 recursive_update
422
423 The method that does the work here.
424
425 =head2 is_m2m
426
427 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
428 (pseudo) relation on $self.
429
430 =head2 get_m2m_source
431
432 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
433 to many (pseudo) relation 'name' from $self.
434
435
436 =head1 DIAGNOSTICS
437
438
439 =head1 CONFIGURATION AND ENVIRONMENT
440
441 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
442
443 =head1 DEPENDENCIES
444
445 DBIx::Class
446
447 =head1 INCOMPATIBILITIES
448
449 =for author to fill in:
450
451 None reported.
452
453
454 =head1 BUGS AND LIMITATIONS
455
456 =for author to fill in:
457
458 No bugs have been reported.
459
460 Please report any bugs or feature requests to
461 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
462 L<http://rt.cpan.org>.
463
464
465 =head1 AUTHOR
466
467 Zbigniew Lukasiak C<< <zby@cpan.org> >>
468 Influenced by code by Pedro Melo.
469
470 =head1 LICENCE AND COPYRIGHT
471
472 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
473
474 This module is free software; you can redistribute it and/or
475 modify it under the same terms as Perl itself. See L<perlartistic>.
476
477
478 =head1 DISCLAIMER OF WARRANTY
479
480 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
481 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
482 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
483 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
484 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
485 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
486 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
487 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
488 NECESSARY SERVICING, REPAIR, OR CORRECTION.
489
490 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
491 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
492 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
493 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
494 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
495 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
496 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
497 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
498 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
499 SUCH DAMAGES.
This page took 0.067968 seconds and 4 git commands to generate.