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