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