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