1 package DBIx
::Class
::ResultSet
::RecursiveUpdate
;
3 use version
; $VERSION = qv
('0.0.1');
9 use base
qw(DBIx::Class::ResultSet);
11 sub recursive_update
{
12 my( $self, $updates ) = @_;
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' ){
17 $object = $self->new( {} );
20 $object = $self->find( $updates, { key
=> 'primary' } ) || $self->new( {} );
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
27 if( $object->result_source->has_relationship($name)
31 my $info = $object->result_source->relationship_info( $name );
32 if( $info and not $info->{attrs
}{accessor
} eq 'multi'
34 _master_relation_cond
( $object, $info->{cond
}, _get_pk_for_related
( $object, $name ) )
36 my $related_result = $object->related_resultset( $name );
38 my $sub_object = $related_result->recursive_update( $value );
39 $object->set_from_related( $name, $sub_object );
42 # columns and other accessors
43 elsif( $object->result_source->has_column($name)
45 !$object->can( 'set_' . $name )
47 $object->$name($value);
50 #warn Dumper($object->{_column_data}); use Data::Dumper;
52 _delete_empty_auto_increment
($object);
53 $object->update_or_insert;
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};
60 if($object->can($name) and
61 !$object->result_source->has_relationship($name) and
62 $object->can( 'set_' . $name )
64 my ( $pk ) = _get_pk_for_related
( $object, $name );
65 my @values = @{$updates->{$name}};
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 );
72 elsif( $object->result_source->has_relationship($name) ){
73 my $info = $object->result_source->relationship_info( $name );
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 );
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 );
90 sub _delete_empty_auto_increment
{
92 for my $col ( keys %{$object->{_column_data
}}){
93 if( $object->result_source->column_info( $col )->{is_auto_increment
}
95 ( ! defined $object->{_column_data
}{$col} or $object->{_column_data
}{$col} eq '' )
97 delete $object->{_column_data
}{$col}
102 sub _get_pk_for_related
{
103 my ( $object, $relation ) = @_;
105 my $rs = $object->result_source->resultset;
106 my $result_source = _get_related_source
( $rs, $relation );
107 return $result_source->primary_columns;
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 );
116 my $row = $rs->new({});
117 if ( $row->can( $name ) and $row->can( 'add_to_' . $name ) and $row->can( 'set_' . $name ) ){
119 return $r->result_source;
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};
132 if( $object->column_info( $col )->{is_auto_increment
} ){
135 if( $f_key =~ /^foreign\.$foreign_ids_re/ ){
139 }elsif ( ref $cond eq 'ARRAY' ){
140 for my $new_cond ( @$cond ) {
141 return 1 if _master_relation_cond
( $object, $new_cond, @foreign_ids );
147 # Module implementation here
150 1; # Magic true value required at end of module
155 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
160 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.0.1
165 __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
167 in the Schema file (see t/lib/DBSchema.pm). Or appriopriate 'use base' in the ResultSet classes.
171 =for author to fill in:
173 my $user = $user_rs->recursive_update( {
178 title => 'One Flew Over the Cuckoo's Nest'
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.
200 For a description how to set up base classes for ResultSets see load_namespaces
201 in DBIx::Class::Schema.
205 =for author to fill in:
209 =head2 recursive_update
211 The only method here.
216 =head1 CONFIGURATION AND ENVIRONMENT
218 =for author to fill in:
220 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
225 =for author to fill in:
232 =head1 INCOMPATIBILITIES
234 =for author to fill in:
239 =head1 BUGS AND LIMITATIONS
241 =for author to fill in:
243 No bugs have been reported.
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>.
252 Zbigniew Lukasiak C<< <zby@cpan.org> >>
253 Influenced by code by Pedro Melo.
255 =head1 LICENCE AND COPYRIGHT
257 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
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>.
263 =head1 DISCLAIMER OF WARRANTY
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.
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