Initial
[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.0.1');
4
5 use warnings;
6 use strict;
7 use Carp;
8
9 use base qw(DBIx::Class::ResultSet);
10
11 sub recursive_update {
12 my( $self, $updates ) = @_;
13 my $object;
14 # this is a workaround for a bug in the svn version 4794
15 if ( ref $self->{cond} eq 'ARRAY' and ref $self->{cond}[0] eq 'SCALAR' ){
16 $self->{cond} = {};
17 $object = $self->new( {} );
18 }
19 else {
20 $object = $self->find( $updates, { key => 'primary' } ) || $self->new( {} );
21 }
22
23 for my $name ( keys %$updates ){ if($object->can($name)){
24 my $value = $updates->{$name};
25 # updating relations that that should be done before the row is inserted into the database
26 # like belongs_to
27 if( $object->result_source->has_relationship($name)
28 and
29 ref $value
30 ){
31 my $info = $object->result_source->relationship_info( $name );
32 if( $info and not $info->{attrs}{accessor} eq 'multi'
33 and
34 _master_relation_cond( $object, $info->{cond}, _get_pk_for_related( $object, $name ) )
35 ){
36 my $related_result = $object->related_resultset( $name );
37 $DB::single = 1;
38 my $sub_object = $related_result->recursive_update( $value );
39 $object->set_from_related( $name, $sub_object );
40 }
41 }
42 # columns and other accessors
43 elsif( $object->result_source->has_column($name)
44 or
45 !$object->can( 'set_' . $name )
46 ) {
47 $object->$name($value);
48 }
49 }
50 #warn Dumper($object->{_column_data}); use Data::Dumper;
51 }
52 _delete_empty_auto_increment($object);
53 $object->update_or_insert;
54
55 # updating relations that can be done only after the row is inserted into the database
56 # like has_many and many_to_many
57 for my $name ( keys %$updates ){
58 my $value = $updates->{$name};
59 # many to many case
60 if($object->can($name) and
61 !$object->result_source->has_relationship($name) and
62 $object->can( 'set_' . $name )
63 ) {
64 my ( $pk ) = _get_pk_for_related( $object, $name );
65 my @values = @{$updates->{$name}};
66 my @rows;
67 my $result_source = $object->$name->result_source;
68 @rows = $result_source->resultset->search({ $pk => [ @values ] } ) if @values;
69 my $set_meth = 'set_' . $name;
70 $object->$set_meth( \@rows );
71 }
72 elsif( $object->result_source->has_relationship($name) ){
73 my $info = $object->result_source->relationship_info( $name );
74 # has many case
75 if( ref $updates->{$name} eq 'ARRAY' ){
76 for my $sub_updates ( @{$updates->{$name}} ) {
77 my $sub_object = $object->search_related( $name )->recursive_update( $sub_updates );
78 }
79 }
80 # might_have and has_one case
81 elsif ( ! _master_relation_cond( $object, $info->{cond}, _get_pk_for_related( $object, $name ) ) ){
82 my $sub_object = $object->search_related( $name )->recursive_update( $value );
83 #$object->set_from_related( $name, $sub_object );
84 }
85 }
86 }
87 return $object;
88 }
89
90 sub _delete_empty_auto_increment {
91 my ( $object ) = @_;
92 for my $col ( keys %{$object->{_column_data}}){
93 if( $object->result_source->column_info( $col )->{is_auto_increment}
94 and
95 ( ! defined $object->{_column_data}{$col} or $object->{_column_data}{$col} eq '' )
96 ){
97 delete $object->{_column_data}{$col}
98 }
99 }
100 }
101
102 sub _get_pk_for_related {
103 my ( $object, $relation ) = @_;
104
105 my $rs = $object->result_source->resultset;
106 my $result_source = _get_related_source( $rs, $relation );
107 return $result_source->primary_columns;
108 }
109
110 sub _get_related_source {
111 my ( $rs, $name ) = @_;
112 if( $rs->result_source->has_relationship( $name ) ){
113 return $rs->result_source->related_source( $name );
114 }
115 # many to many case
116 my $row = $rs->new({});
117 if ( $row->can( $name ) and $row->can( 'add_to_' . $name ) and $row->can( 'set_' . $name ) ){
118 my $r = $row->$name;
119 return $r->result_source;
120 }
121 return;
122 }
123
124 sub _master_relation_cond {
125 my ( $object, $cond, @foreign_ids ) = @_;
126 my $foreign_ids_re = join '|', @foreign_ids;
127 if ( ref $cond eq 'HASH' ){
128 for my $f_key ( keys %{$cond} ) {
129 # might_have is not master
130 my $col = $cond->{$f_key};
131 $col =~ s/self\.//;
132 if( $object->column_info( $col )->{is_auto_increment} ){
133 return 0;
134 }
135 if( $f_key =~ /^foreign\.$foreign_ids_re/ ){
136 return 1;
137 }
138 }
139 }elsif ( ref $cond eq 'ARRAY' ){
140 for my $new_cond ( @$cond ) {
141 return 1 if _master_relation_cond( $object, $new_cond, @foreign_ids );
142 }
143 }
144 return;
145 }
146
147 # Module implementation here
148
149
150 1; # Magic true value required at end of module
151 __END__
152
153 =head1 NAME
154
155 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
156
157
158 =head1 VERSION
159
160 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.0.1
161
162
163 =head1 SYNOPSIS
164
165 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
166
167 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
168
169 Then:
170
171 =for author to fill in:
172
173 my $user = $user_rs->recursive_update( {
174 id => 1,
175 owned_dvds => [
176 {
177 id => undef,
178 title => 'One Flew Over the Cuckoo's Nest'
179 }
180 ]
181 }
182 );
183
184
185 =head1 DESCRIPTION
186
187 =for author to fill in:
188 You can feed the ->create method with a recursive datastructure and have the related records
189 created. Unfortunately you cannot do a similar thing with update_or_create - this module
190 tries to fill that void.
191 It is a base class for ResultSets providing just one method: recursive_update
192 which works just like update_or_create but can recursively update or create
193 data objects composed of multiple rows. All rows need to be identified by primary keys
194 - so you need to provide them in the update structure (unless they can be deduced from
195 the parent row - for example when you have a belongs_to relationship).
196 When creating new rows in a table with auto_increment primary keys you need to
197 put 'undef' for the key value - this is then removed
198 and a correct INSERT statement is generated.
199
200 For a description how to set up base classes for ResultSets see load_namespaces
201 in DBIx::Class::Schema.
202
203 =head1 INTERFACE
204
205 =for author to fill in:
206
207 =head1 METHODS
208
209 =head2 recursive_update
210
211 The only method here.
212
213 =head1 DIAGNOSTICS
214
215
216 =head1 CONFIGURATION AND ENVIRONMENT
217
218 =for author to fill in:
219
220 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
221
222
223 =head1 DEPENDENCIES
224
225 =for author to fill in:
226
227 DBIx::Class
228
229 None.
230
231
232 =head1 INCOMPATIBILITIES
233
234 =for author to fill in:
235
236 None reported.
237
238
239 =head1 BUGS AND LIMITATIONS
240
241 =for author to fill in:
242
243 No bugs have been reported.
244
245 Please report any bugs or feature requests to
246 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
247 L<http://rt.cpan.org>.
248
249
250 =head1 AUTHOR
251
252 Zbigniew Lukasiak C<< <zby@cpan.org> >>
253 Influenced by code by Pedro Melo.
254
255 =head1 LICENCE AND COPYRIGHT
256
257 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
258
259 This module is free software; you can redistribute it and/or
260 modify it under the same terms as Perl itself. See L<perlartistic>.
261
262
263 =head1 DISCLAIMER OF WARRANTY
264
265 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
266 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
267 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
268 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
269 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
270 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
271 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
272 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
273 NECESSARY SERVICING, REPAIR, OR CORRECTION.
274
275 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
276 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
277 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
278 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
279 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
280 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
281 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
282 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
283 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
284 SUCH DAMAGES.
This page took 0.057404 seconds and 5 git commands to generate.