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