]> Dogcows Code - chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate/blob - lib/DBIx/Class/ResultSet/RecursiveUpdate.pm
42dec8d1a3f60ae0437d0baf30e8108ca3b738a9
[chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate] / lib / DBIx / Class / ResultSet / RecursiveUpdate.pm
1 package DBIx::Class::ResultSet::RecursiveUpdate;
2
3 use version; $VERSION = qv('0.001');
4
5 use warnings;
6 use strict;
7 use Carp;
8 use Scalar::Util qw( blessed );
9
10 use base qw(DBIx::Class::ResultSet);
11
12 sub recursive_update {
13 my( $self, $updates, $fixed_fields ) = @_;
14 # warn 'entering: ' . $self->result_source->from();
15 if( blessed( $updates ) && $updates->isa( 'DBIx::Class::Row' ) ){
16 return $updates;
17 }
18 my $object;
19 # warn 'fixed_fields: ' . Dumper( $fixed_fields ); use Data::Dumper;
20 if( $fixed_fields ){
21 carp if !( ref( $fixed_fields ) eq 'HASH' );
22 $updates = { %$updates, %$fixed_fields };
23 }
24 my %columns;
25 for my $name ( keys %$updates ){
26 if( $self->is_for_column( $name, $updates->{$name} ) ){
27 $columns{$name} = $updates->{$name};
28 }
29 }
30 # warn 'columns: ' . Dumper( \%columns ); use Data::Dumper;
31 my @missing = grep { !exists $columns{$_} } $self->result_source->primary_columns;
32 if( ! scalar @missing ){
33 $object = $self->find( \%columns, { key => 'primary' } );
34 }
35 $object ||= $self->new( {} );
36
37 # first update columns and other accessors - so that later related records can be found
38 for my $name ( keys %columns ){
39 $object->$name( $updates->{$name} );
40 }
41 for my $name ( keys %$updates ){
42 next if exists $columns{ $name };
43 if(
44 #$object->can($name)
45 $object->result_source->has_relationship($name)
46 && !$self->is_for_column( $object, $name, $updates->{$name} )
47 ){
48 # updating relations that that should be done before the row is inserted into the database
49 # like belongs_to
50 my $info = $object->result_source->relationship_info( $name );
51 if( $info #and not $info->{attrs}{accessor} eq 'multi'
52 and
53 _master_relation_cond( $object->result_source, $info->{cond}, $self->_get_pk_for_related( $name ) )
54 ){
55 my $related_result = $self->related_resultset( $name )->result_source->resultset;
56 my $resolved = $self->result_source->resolve_condition(
57 $info->{cond}, $name, $object
58 );
59 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
60 $resolved = undef if $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION == $resolved;
61 if( ref $updates->{$name} eq 'ARRAY' ){
62 for my $sub_updates ( @{$updates->{$name}} ) {
63 my $sub_object = $related_result->recursive_update( $sub_updates, $resolved );
64 }
65 }
66 else {
67 my $sub_object = $related_result->recursive_update( $updates->{$name}, $resolved );
68 $object->set_from_related( $name, $sub_object );
69 }
70 }
71 }
72 }
73 $self->_delete_empty_auto_increment($object);
74 # don't allow insert to recurse to related objects - we do the recursion ourselves
75 # $object->{_rel_in_storage} = 1;
76 $object->update_or_insert;
77
78 # updating relations that can be done only after the row is inserted into the database
79 # like has_many and many_to_many
80 for my $name ( keys %$updates ){
81 next if exists $columns{ $name };
82 my $value = $updates->{$name};
83 # many to many case
84 if( $self->is_m2m( $name ) ) {
85 my ( $pk ) = $self->_get_pk_for_related( $name );
86 my @rows;
87 my $result_source = $object->$name->result_source;
88 for my $elem ( @{$updates->{$name}} ){
89 if( ref $elem ){
90 push @rows, $result_source->resultset->find( $elem );
91 }
92 else{
93 push @rows, $result_source->resultset->find( { $pk => $elem } );
94 }
95 }
96 my $set_meth = 'set_' . $name;
97 $object->$set_meth( \@rows );
98 }
99 elsif( $object->result_source->has_relationship($name) ){
100 my $info = $object->result_source->relationship_info( $name );
101 next if ( _master_relation_cond( $object->result_source, $info->{cond}, $self->_get_pk_for_related( $name ) ) );
102 # has many case (and similar)
103 my $resolved = $self->result_source->resolve_condition(
104 $info->{cond}, $name, $object
105 );
106 # warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
107 $resolved = undef if $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION == $resolved;
108 my $related_result = $self->related_resultset( $name )->result_source->resultset;
109 if( ref $updates->{$name} eq 'ARRAY' ){
110 for my $sub_updates ( @{$updates->{$name}} ) {
111 my $sub_object = $related_result->recursive_update( $sub_updates, $resolved );
112 }
113 }
114 # might_have and has_one case
115 else{
116 my $sub_object = $related_result->recursive_update( $value, $resolved );
117 #$object->set_from_related( $name, $sub_object );
118 }
119 }
120 }
121 return $object;
122 }
123
124 sub is_for_column {
125 my( $self, $name, $value ) = @_;
126 my $source = $self->result_source;
127 return
128 $source->has_column($name)
129 && !(
130 $source->has_relationship($name)
131 && ref( $value )
132 )
133 }
134
135
136 sub is_m2m {
137 my( $self, $relation ) = @_;
138 my $rclass = $self->result_class;
139 # DBIx::Class::IntrospectableM2M
140 if( $rclass->can( '_m2m_metadata' ) ){
141 return $rclass->_m2m_metadata->{$relation};
142 }
143 my $object = $self->new({});
144 if ( $object->can($relation) and
145 !$self->result_source->has_relationship($relation) and
146 $object->can( 'set_' . $relation)
147 ){
148 return 1;
149 }
150 return;
151 }
152
153 sub get_m2m_source {
154 my( $self, $relation ) = @_;
155 my $rclass = $self->result_class;
156 # DBIx::Class::IntrospectableM2M
157 if( $rclass->can( '_m2m_metadata' ) ){
158 return $self->result_source
159 ->related_source(
160 $rclass->_m2m_metadata->{$relation}{relation}
161 )
162 ->related_source(
163 $rclass->_m2m_metadata->{$relation}{foreign_relation}
164 );
165 }
166 my $object = $self->new({});
167 my $r = $object->$relation;
168 return $r->result_source;
169 }
170
171
172 sub _delete_empty_auto_increment {
173 my ( $self, $object ) = @_;
174 for my $col ( keys %{$object->{_column_data}}){
175 if( $object->result_source->column_info( $col )->{is_auto_increment}
176 and
177 ( ! defined $object->{_column_data}{$col} or $object->{_column_data}{$col} eq '' )
178 ){
179 delete $object->{_column_data}{$col}
180 }
181 }
182 }
183
184 sub _get_pk_for_related {
185 my ( $self, $relation ) = @_;
186 my $result_source;
187 if( $self->result_source->has_relationship( $relation ) ){
188 $result_source = $self->result_source->related_source( $relation );
189 }
190 # many to many case
191 if ( $self->is_m2m( $relation ) ) {
192 $result_source = $self->get_m2m_source( $relation );
193 }
194 return $result_source->primary_columns;
195 }
196
197 sub _master_relation_cond {
198 my ( $source, $cond, @foreign_ids ) = @_;
199 my $foreign_ids_re = join '|', @foreign_ids;
200 if ( ref $cond eq 'HASH' ){
201 for my $f_key ( keys %{$cond} ) {
202 # might_have is not master
203 my $col = $cond->{$f_key};
204 $col =~ s/self\.//;
205 if( $source->column_info( $col )->{is_auto_increment} ){
206 return 0;
207 }
208 if( $f_key =~ /^foreign\.$foreign_ids_re/ ){
209 return 1;
210 }
211 }
212 }elsif ( ref $cond eq 'ARRAY' ){
213 for my $new_cond ( @$cond ) {
214 return 1 if _master_relation_cond( $source, $new_cond, @foreign_ids );
215 }
216 }
217 return;
218 }
219
220 1; # Magic true value required at end of module
221 __END__
222
223 =head1 NAME
224
225 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
226
227
228 =head1 VERSION
229
230 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.001
231
232
233 =head1 SYNOPSIS
234
235 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
236
237 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
238
239 Then:
240
241 my $user = $user_rs->recursive_update( {
242 id => 1,
243 owned_dvds => [
244 {
245 id => undef,
246 title => 'One Flew Over the Cuckoo's Nest'
247 }
248 ]
249 }
250 );
251
252
253 =head1 DESCRIPTION
254
255 You can feed the ->create method with a recursive datastructure and have the related records
256 created. Unfortunately you cannot do a similar thing with update_or_create - this module
257 tries to fill that void.
258
259 It is a base class for ResultSets providing just one method: recursive_update
260 which works just like update_or_create but can recursively update or create
261 data objects composed of multiple rows. All rows need to be identified by primary keys
262 - so you need to provide them in the update structure (unless they can be deduced from
263 the parent row - for example when you have a belongs_to relationship).
264 When creating new rows in a table with auto_increment primary keys you need to
265 put 'undef' for the key value - this is then removed
266 and a correct INSERT statement is generated.
267
268 For a many_to_many (pseudo) relation you can supply a list of primary keys
269 from the other table - and it will link the record at hand to those and
270 only those records identified by them. This is convenient for handling web
271 forms with check boxes (or a SELECT box with multiple choice) that let you
272 update such (pseudo) relations.
273
274 For a description how to set up base classes for ResultSets see load_namespaces
275 in DBIx::Class::Schema.
276
277 =head1 DESIGN CHOICES
278
279 =head2 Treatment of many to many pseudo relations
280
281 Matt Trout expressed following criticism of the support for many to many in
282 RecursiveUpdate and since this is an extension of his DBIx::Class I feel obliged to
283 reply to it. It is about two points leading in his opinion to 'fragile and
284 implicitely broken code'.
285
286 1. That I rely on the fact that
287
288 if($object->can($name) and
289 !$object->result_source->has_relationship($name) and
290 $object->can( 'set_' . $name )
291 )
292
293 then $name must be a many to many pseudo relation. And that in a
294 similarly ugly was I find out what is the ResultSource of objects from
295 that many to many pseudo relation.
296
297 2. That I treat uniformly relations and many to many (which are
298 different from relations because they require traversal of the bridge
299 table).
300
301 To answer 1) I've refactored that 'dirty' code into is_m2m and get_m2m_source so
302 that it can be easily overridden. I agree that this code is not too nice - but
303 currenlty it is the only way to do what I need - and I'll replace it as soon as
304 there is a more clean way. I don't think it is extremely brittle - sure it will
305 break if many to many (pseudo) relations don't get 'set_*' methods anymore - but
306 I would say it is rather justified for this kind of change in underlying library
307 to break it.
308
309
310 Ad 2) - first this is not strictly true - RecursiveUpdate does have
311 different code to cope with m2m and other cases (see the point above for
312 example) - but it let's the user to treat m2m and 'normal' relations in a
313 uniform way. I consider this a form of abstraction - it is the work that
314 RecursiveUpdate does for the programmer.
315
316
317 =head1 INTERFACE
318
319 =head1 METHODS
320
321 =head2 recursive_update
322
323 The method that does the work here.
324
325 =head2 is_m2m
326
327 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
328 (pseudo) relation on $self.
329
330 =head2 get_m2m_source
331
332 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
333 to many (pseudo) relation 'name' from $self.
334
335
336 =head1 DIAGNOSTICS
337
338
339 =head1 CONFIGURATION AND ENVIRONMENT
340
341 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
342
343 =head1 DEPENDENCIES
344
345 DBIx::Class
346
347 =head1 INCOMPATIBILITIES
348
349 =for author to fill in:
350
351 None reported.
352
353
354 =head1 BUGS AND LIMITATIONS
355
356 =for author to fill in:
357
358 No bugs have been reported.
359
360 Please report any bugs or feature requests to
361 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
362 L<http://rt.cpan.org>.
363
364
365 =head1 AUTHOR
366
367 Zbigniew Lukasiak C<< <zby@cpan.org> >>
368 Influenced by code by Pedro Melo.
369
370 =head1 LICENCE AND COPYRIGHT
371
372 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
373
374 This module is free software; you can redistribute it and/or
375 modify it under the same terms as Perl itself. See L<perlartistic>.
376
377
378 =head1 DISCLAIMER OF WARRANTY
379
380 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
381 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
382 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
383 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
384 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
385 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
386 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
387 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
388 NECESSARY SERVICING, REPAIR, OR CORRECTION.
389
390 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
391 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
392 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
393 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
394 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
395 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
396 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
397 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
398 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
399 SUCH DAMAGES.
This page took 0.074427 seconds and 3 git commands to generate.