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