Dogcows Code - chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate/blob - 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.