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