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