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