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