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.001');
   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}, $self->_get_pk_for_related( $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     $self->_delete_empty_auto_increment($object);
  47     # don't allow insert to recurse to related objects - we do the recursion ourselves
  48     $object->{_rel_in_storage} = 1;
  49     $object->update_or_insert;
  50
  51     # updating relations that can be done only after the row is inserted into the database
  52     # like has_many and many_to_many
  53     for my $name ( keys %$updates ){
  54         my $value = $updates->{$name};
  55         # many to many case
  56         if( $self->is_m2m( $name ) ) {
  57                 my ( $pk ) = $self->_get_pk_for_related( $name );
  58                 my @rows;
  59                 my $result_source = $object->$name->result_source;
  60                 for my $elem ( @{$updates->{$name}} ){
  61                     if( ref $elem ){
  62                         push @rows, $result_source->resultset->find( $elem );
  63                     }
  64                     else{
  65                         push @rows, $result_source->resultset->find( { $pk => $elem } );
  66                     }
  67                 }
  68                 my $set_meth = 'set_' . $name;
  69                 $object->$set_meth( \@rows );
  70         }
  71         elsif( $object->result_source->has_relationship($name) ){
  72             my $info = $object->result_source->relationship_info( $name );
  73             # has many case
  74             if( ref $updates->{$name} eq 'ARRAY' ){
  75                 for my $sub_updates ( @{$updates->{$name}} ) {
  76                     my $sub_object = $object->search_related( $name )->recursive_update( $sub_updates );
  77                 }
  78             }
  79             # might_have and has_one case
  80             elsif ( ! _master_relation_cond( $object, $info->{cond}, $self->_get_pk_for_related( $name ) ) ){
  81                 my $sub_object = $object->search_related( $name )->recursive_update( $value );
  82                 #$object->set_from_related( $name, $sub_object );
  83             }
  84         }
  85     }
  86     return $object;
  87 }
  88
  89 sub is_m2m {
  90     my( $self, $relation ) = @_;
  91     my $object = $self->new({});
  92     if ( $object->can($relation) and
  93         !$object->result_source->has_relationship($relation) and
  94         $object->can( 'set_' . $relation)
  95     ){
  96         return 1;
  97     }
  98     return;
  99 }
 100
 101 sub get_m2m_source {
 102     my( $self, $relation ) = @_;
 103     my $object = $self->new({});
 104     my $r = $object->$relation;
 105     return $r->result_source;
 106 }
 107
 108
 109 sub _delete_empty_auto_increment {
 110     my ( $self, $object ) = @_;
 111     for my $col ( keys %{$object->{_column_data}}){
 112         if( $object->result_source->column_info( $col )->{is_auto_increment}
 113                 and
 114             ( ! defined $object->{_column_data}{$col} or $object->{_column_data}{$col} eq '' )
 115         ){
 116             delete $object->{_column_data}{$col}
 117         }
 118     }
 119 }
 120
 121 sub _get_pk_for_related {
 122     my ( $self, $relation ) = @_;
 123
 124     my $result_source;
 125     if( $self->result_source->has_relationship( $relation ) ){
 126         $result_source = $self->result_source->related_source( $relation );
 127     }
 128     # many to many case
 129     if ( $self->is_m2m( $relation ) ) {
 130         $result_source = $self->get_m2m_source( $relation );
 131     }
 132     return $result_source->primary_columns;
 133 }
 134
 135 sub _master_relation_cond {
 136     my ( $object, $cond, @foreign_ids ) = @_;
 137     my $foreign_ids_re = join '|', @foreign_ids;
 138     if ( ref $cond eq 'HASH' ){
 139         for my $f_key ( keys %{$cond} ) {
 140             # might_have is not master
 141             my $col = $cond->{$f_key};
 142             $col =~ s/self\.//;
 143             if( $object->column_info( $col )->{is_auto_increment} ){
 144                 return 0;
 145             }
 146             if( $f_key =~ /^foreign\.$foreign_ids_re/ ){
 147                 return 1;
 148             }
 149         }
 150     }elsif ( ref $cond eq 'ARRAY' ){
 151         for my $new_cond ( @$cond ) {
 152             return 1 if _master_relation_cond( $object, $new_cond, @foreign_ids );
 153         }
 154     }
 155     return;
 156 }
 157
 158 # Module implementation here
 159
 160
 161 1; # Magic true value required at end of module
 162 __END__
 163
 164 =head1 NAME
 165
 166 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
 167
 168
 169 =head1 VERSION
 170
 171 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.001
 172
 173
 174 =head1 SYNOPSIS
 175
 176     __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
 177
 178 in the Schema file (see t/lib/DBSchema.pm).  Or appriopriate 'use base' in the ResultSet classes.
 179
 180 Then:
 181
 182     my $user = $user_rs->recursive_update( {
 183         id => 1,
 184         owned_dvds => [
 185         {
 186           id => undef,
 187           title => 'One Flew Over the Cuckoo's Nest'
 188         }
 189         ]
 190       }
 191     );
 192
 193
 194 =head1 DESCRIPTION
 195
 196 You can feed the ->create method with a recursive datastructure and have the related records
 197 created.  Unfortunately you cannot do a similar thing with update_or_create - this module
 198 tries to fill that void.
 199
 200 It is a base class for ResultSets providing just one method: recursive_update
 201 which works just like update_or_create but can recursively update or create
 202 data objects composed of multiple rows. All rows need to be identified by primary keys
 203 - so you need to provide them in the update structure (unless they can be deduced from
 204 the parent row - for example when you have a belongs_to relationship).
 205 When creating new rows in a table with auto_increment primary keys you need to
 206 put 'undef' for the key value - this is then removed
 207 and a correct INSERT statement is generated.
 208
 209 For a many_to_many (pseudo) relation you can supply a list of primary keys
 210 from the other table - and it will link the record at hand to those and
 211 only those records identified by them.  This is convenient for handling web
 212 forms with check boxes (or a SELECT box with multiple choice) that let you
 213 update such (pseudo) relations.
 214
 215 For a description how to set up base classes for ResultSets see load_namespaces
 216 in DBIx::Class::Schema.
 217
 218 =head1 DESIGN CHOICES
 219
 220 =head2 Treatment of many to many pseudo relations
 221
 222 Matt Trout expressed following criticism of the support for many to many in
 223 RecursiveUpdate and since this is an extension of his DBIx::Class I feel obliged to
 224 reply to it.  It is about two points leading in his opinion to 'fragile and
 225 implicitely broken code'.
 226
 227 1. That I rely on the fact that
 228
 229  if($object->can($name) and
 230              !$object->result_source->has_relationship($name) and
 231              $object->can( 'set_' . $name )
 232          )
 233
 234 then $name must be a many to many pseudo relation.  And that in a
 235 similarly ugly was I find out what is the ResultSource of objects from
 236 that many to many pseudo relation.
 237
 238 2. That I treat uniformly relations and many to many (which are
 239 different from relations because they require traversal of the bridge
 240 table).
 241
 242 To answer 1) I've refactored that 'dirty' code into is_m2m and get_m2m_source so
 243 that it can be easily overridden.  I agree that this code is not too nice - but
 244 currenlty it is the only way to do what I need - and I'll replace it as soon as
 245 there is a more clean way.  I don't think it is extremely brittle - sure it will
 246 break if many to many (pseudo) relations don't get 'set_*' methods anymore - but
 247 I would say it is rather justified for this kind of change in underlying library
 248 to break it.
 249
 250
 251 Ad 2) - first this is not strictly true - RecursiveUpdate does have
 252 different code to cope with m2m and other cases (see the point above for
 253 example) - but it let's the user to treat m2m and 'normal' relations in a
 254 uniform way.  I consider this a form of abstraction - it is the work that
 255 RecursiveUpdate does for the programmer.
 256
 257
 258 =head1 INTERFACE
 259
 260 =head1 METHODS
 261
 262 =head2 recursive_update
 263
 264 The method that does the work here.
 265
 266 =head2 is_m2m
 267
 268 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
 269 (pseudo) relation on $self.
 270
 271 =head2 get_m2m_source
 272
 273 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
 274 to many (pseudo) relation 'name' from $self.
 275
 276
 277 =head1 DIAGNOSTICS
 278
 279
 280 =head1 CONFIGURATION AND ENVIRONMENT
 281
 282 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
 283
 284 =head1 DEPENDENCIES
 285
 286     DBIx::Class
 287
 288 =head1 INCOMPATIBILITIES
 289
 290 =for author to fill in:
 291
 292 None reported.
 293
 294
 295 =head1 BUGS AND LIMITATIONS
 296
 297 =for author to fill in:
 298
 299 No bugs have been reported.
 300
 301 Please report any bugs or feature requests to
 302 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
 303 L<http://rt.cpan.org>.
 304
 305
 306 =head1 AUTHOR
 307
 308 Zbigniew Lukasiak  C<< <zby@cpan.org> >>
 309 Influenced by code by Pedro Melo.
 310
 311 =head1 LICENCE AND COPYRIGHT
 312
 313 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
 314
 315 This module is free software; you can redistribute it and/or
 316 modify it under the same terms as Perl itself. See L<perlartistic>.
 317
 318
 319 =head1 DISCLAIMER OF WARRANTY
 320
 321 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 322 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 323 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 324 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 325 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 326 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 327 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 328 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 329 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 330
 331 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 332 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 333 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 334 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 335 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 336 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 337 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 338 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 339 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 340 SUCH DAMAGES.