Dogcows Code - chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate/blob - lib/DBIx/Class/ResultSet/RecursiveUpdate.pm

   1 use strict;
   2 use warnings;
   3 package DBIx::Class::ResultSet::RecursiveUpdate;
   4
   5 use version; our $VERSION = qv('0.007');
   6
   7 use base qw(DBIx::Class::ResultSet);
   8
   9 sub recursive_update {
  10     my ( $self, $updates, $fixed_fields ) = @_;
  11     return DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update(
  12         resultset    => $self,
  13         updates      => $updates,
  14         fixed_fields => $fixed_fields
  15     );
  16 }
  17
  18 package DBIx::Class::ResultSet::RecursiveUpdate::Functions;
  19 use Carp;
  20 use Scalar::Util qw( blessed );
  21
  22
  23 sub recursive_update {
  24     my %params = @_;
  25     my ( $self, $updates, $fixed_fields, $object ) = @params{ qw/resultset updates fixed_fields object/ };
  26     # warn 'entering: ' . $self->result_source->from();
  27     carp 'fixed fields needs to be an array ref' if $fixed_fields && ref($fixed_fields) ne 'ARRAY';
  28     my %fixed_fields;
  29     %fixed_fields = map { $_ => 1 } @$fixed_fields if $fixed_fields;
  30     if ( blessed($updates) && $updates->isa('DBIx::Class::Row') ) {
  31         return $updates;
  32     }
  33     # warn Dumper( $updates ); use Data::Dumper;
  34     # direct column accessors
  35     my %columns;
  36
  37     # relations that that should be done before the row is inserted into the database
  38     # like belongs_to
  39     my %pre_updates;
  40
  41     # relations that that should be done after the row is inserted into the database
  42     # like has_many and might_have
  43     my %post_updates;
  44     my %other_methods;
  45     my %columns_by_accessor = _get_columns_by_accessor( $self );
  46     for my $name ( keys %$updates ) {
  47         my $source = $self->result_source;
  48         if( $name eq 'id'
  49 #            && scalar @{$source->primary_columns} == 1
  50             && !$source->has_column( 'id' )
  51         ){
  52             my @ids = ( $updates->{id} );
  53             if( ref $updates->{id} ){
  54                 @ids = @{ $updates->{id} };
  55             }
  56             my $i = 0;
  57             for my $key ( $source->primary_columns ){
  58                 $columns{ $key } = $ids[ $i++ ];
  59             }
  60             next;
  61         }
  62         if ( $columns_by_accessor{$name}
  63             && !( $source->has_relationship($name) && ref( $updates->{$name} ) )
  64           )
  65         {
  66             $columns{$name} = $updates->{$name};
  67             next;
  68         }
  69         if( !( $source->has_relationship($name) ) ){
  70             $other_methods{$name} = $updates->{$name};
  71             next;
  72         }
  73         my $info = $source->relationship_info($name);
  74         if (
  75             _master_relation_cond(
  76                 $source, $info->{cond}, _get_pk_for_related( $self, $name)
  77             )
  78           )
  79         {
  80             $pre_updates{$name} = $updates->{$name};
  81         }
  82         else {
  83             $post_updates{$name} = $updates->{$name};
  84         }
  85     }
  86     # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
  87
  88     my @missing =
  89       grep { !exists $columns{$_} && !exists $fixed_fields{$_} } $self->result_source->primary_columns;
  90     if ( !$object && !scalar @missing ) {
  91         $object = $self->find( \%columns, { key => 'primary' } );
  92     }
  93     $object ||= $self->new( {} );
  94     # first update columns and other accessors - so that later related records can be found
  95     for my $name ( keys %columns ) {
  96         $object->$name( $columns{$name} );
  97     }
  98     for my $name ( keys %other_methods) {
  99         $object->$name( $updates->{$name} ) if $object->can( $name );
 100     }
 101     for my $name ( keys %pre_updates ) {
 102         my $info = $object->result_source->relationship_info($name);
 103         _update_relation( $self, $name, $updates, $object, $info );
 104     }
 105 #    $self->_delete_empty_auto_increment($object);
 106 # don't allow insert to recurse to related objects - we do the recursion ourselves
 107 #    $object->{_rel_in_storage} = 1;
 108     $object->update_or_insert;
 109
 110     # updating many_to_many
 111     for my $name ( keys %$updates ) {
 112         next if exists $columns{$name};
 113         my $value = $updates->{$name};
 114
 115         if ( is_m2m( $self, $name) ) {
 116             my ($pk) = _get_pk_for_related( $self, $name);
 117             my @rows;
 118             my $result_source = $object->$name->result_source;
 119             my @updates;
 120             if( ! defined $value ){
 121                 next;
 122             }
 123             elsif( ref $value ){
 124                 @updates = @{ $value };
 125             }
 126             else{
 127                 @updates = ( $value );
 128             }
 129             for my $elem ( @updates ) {
 130                 if ( ref $elem ) {
 131                     push @rows, $result_source->resultset->find($elem);
 132                 }
 133                 else {
 134                     push @rows,
 135                       $result_source->resultset->find( { $pk => $elem } );
 136                 }
 137             }
 138             my $set_meth = 'set_' . $name;
 139             $object->$set_meth( \@rows );
 140         }
 141     }
 142     for my $name ( keys %post_updates ) {
 143         my $info = $object->result_source->relationship_info($name);
 144         _update_relation( $self, $name, $updates, $object, $info );
 145     }
 146     return $object;
 147 }
 148
 149 sub _get_columns_by_accessor {
 150     my $self   = shift;
 151     my $source = $self->result_source;
 152     my %columns;
 153     for my $name ( $source->columns ) {
 154         my $info = $source->column_info($name);
 155         $info->{name} = $name;
 156         $columns{ $info->{accessor} || $name } = $info;
 157     }
 158     return %columns;
 159 }
 160
 161 sub _update_relation {
 162     my ( $self, $name, $updates, $object, $info ) = @_;
 163     my $related_result =
 164       $self->related_resultset($name)->result_source->resultset;
 165     my $resolved =
 166       $self->result_source->resolve_condition( $info->{cond}, $name, $object );
 167
 168  #                    warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
 169     $resolved = undef
 170       if defined $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION && $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION == $resolved;
 171     if ( ref $updates->{$name} eq 'ARRAY' ) {
 172         for my $sub_updates ( @{ $updates->{$name} } ) {
 173             $sub_updates = { %$sub_updates, %$resolved } if $resolved && ref( $sub_updates ) eq 'HASH';
 174             my $sub_object =
 175               recursive_update( resultset => $related_result, updates => $sub_updates );
 176         }
 177     }
 178     else {
 179         my $sub_updates = $updates->{$name};
 180         my $sub_object;
 181         if( ref $sub_updates ){
 182             $sub_updates = { %$sub_updates, %$resolved } if $resolved && ref( $sub_updates ) eq 'HASH';
 183             # for might_have relationship
 184             if( $info->{attrs}{accessor} eq 'single' && defined $object->$name ){
 185                 $sub_object = recursive_update(
 186                     resultset => $related_result,
 187                     updates => $sub_updates,
 188                     object =>  $object->$name
 189                 );
 190             }
 191             else{
 192                 $sub_object =
 193                 recursive_update( resultset => $related_result, updates => $sub_updates );
 194             }
 195         }
 196         elsif( ! ref $sub_updates ){
 197             $sub_object = $related_result->find( $sub_updates );
 198         }
 199         $object->set_from_related( $name, $sub_object );
 200     }
 201 }
 202
 203 sub is_m2m {
 204     my ( $self, $relation ) = @_;
 205     my $rclass = $self->result_class;
 206
 207     # DBIx::Class::IntrospectableM2M
 208     if ( $rclass->can('_m2m_metadata') ) {
 209         return $rclass->_m2m_metadata->{$relation};
 210     }
 211     my $object = $self->new( {} );
 212     if (    $object->can($relation)
 213         and !$self->result_source->has_relationship($relation)
 214         and $object->can( 'set_' . $relation ) )
 215     {
 216         return 1;
 217     }
 218     return;
 219 }
 220
 221 sub get_m2m_source {
 222     my ( $self, $relation ) = @_;
 223     my $rclass = $self->result_class;
 224
 225     # DBIx::Class::IntrospectableM2M
 226     if ( $rclass->can('_m2m_metadata') ) {
 227         return $self->result_source->related_source(
 228             $rclass->_m2m_metadata->{$relation}{relation} )
 229           ->related_source(
 230             $rclass->_m2m_metadata->{$relation}{foreign_relation} );
 231     }
 232     my $object = $self->new( {} );
 233     my $r = $object->$relation;
 234     return $r->result_source;
 235 }
 236
 237 sub _delete_empty_auto_increment {
 238     my ( $self, $object ) = @_;
 239     for my $col ( keys %{ $object->{_column_data} } ) {
 240         if (
 241             $object->result_source->column_info($col)->{is_auto_increment}
 242             and ( !defined $object->{_column_data}{$col}
 243                 or $object->{_column_data}{$col} eq '' )
 244           )
 245         {
 246             delete $object->{_column_data}{$col};
 247         }
 248     }
 249 }
 250
 251 sub _get_pk_for_related {
 252     my ( $self, $relation ) = @_;
 253     my $result_source;
 254     if ( $self->result_source->has_relationship($relation) ) {
 255         $result_source = $self->result_source->related_source($relation);
 256     }
 257
 258     # many to many case
 259     if ( is_m2m($self, $relation) ) {
 260         $result_source = get_m2m_source($self, $relation);
 261     }
 262     return $result_source->primary_columns;
 263 }
 264
 265 sub _master_relation_cond {
 266     my ( $source, $cond, @foreign_ids ) = @_;
 267     my $foreign_ids_re = join '|', @foreign_ids;
 268     if ( ref $cond eq 'HASH' ) {
 269         for my $f_key ( keys %{$cond} ) {
 270
 271             # might_have is not master
 272             my $col = $cond->{$f_key};
 273             $col =~ s/self\.//;
 274             if ( $source->column_info($col)->{is_auto_increment} ) {
 275                 return 0;
 276             }
 277             if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
 278                 return 1;
 279             }
 280         }
 281     }
 282     elsif ( ref $cond eq 'ARRAY' ) {
 283         for my $new_cond (@$cond) {
 284             return 1
 285               if _master_relation_cond( $source, $new_cond, @foreign_ids );
 286         }
 287     }
 288     return;
 289 }
 290
 291 1;    # Magic true value required at end of module
 292 __END__
 293
 294 =head1 NAME
 295
 296 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
 297
 298
 299 =head1 VERSION
 300
 301 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.006
 302
 303
 304 =head1 SYNOPSIS
 305
 306 The functional interface:
 307
 308     my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
 309         resultset => $schema->resultset( 'Dvd' ),
 310         updates => {
 311             id => 1,
 312             owned_dvds => [
 313                 {
 314                   title => 'One Flew Over the Cuckoo's Nest'
 315                 }
 316             ]
 317         }
 318     });
 319
 320
 321 As ResultSet subclass:
 322
 323     __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
 324
 325 in the Schema file (see t/lib/DBSchema.pm).  Or appriopriate 'use base' in the ResultSet classes.
 326
 327 Then:
 328
 329     my $user = $user_rs->recursive_update( {
 330         id => 1,
 331         owned_dvds => [
 332         {
 333           title => 'One Flew Over the Cuckoo's Nest'
 334         }
 335         ]
 336       }
 337     );
 338
 339
 340 =head1 DESCRIPTION
 341 This is still experimental. I've added a functional interface so that it can be used
 342 in Form Processors and not require modification of the model.
 343
 344 You can feed the ->create method with a recursive datastructure and have the related records
 345 created.  Unfortunately you cannot do a similar thing with update_or_create - this module
 346 tries to fill that void.
 347
 348 It is a base class for ResultSets providing just one method: recursive_update
 349 which works just like update_or_create but can recursively update or create
 350 data objects composed of multiple rows. All rows need to be identified by primary keys
 351 - so you need to provide them in the update structure (unless they can be deduced from
 352 the parent row - for example when you have a belongs_to relationship).
 353 If not all colums comprising the primary key are specified - then a new row will be created,
 354 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
 355 primary keys).
 356
 357
 358 If the resultset itself stores an assignement for the primary key,
 359 like in the case of:
 360
 361     my $restricted_rs = $user_rs->search( { id => 1 } );
 362
 363 then you need to inform recursive_update about additional predicate with a second argument:
 364
 365     my $user = $restricted_rs->recursive_update( {
 366         owned_dvds => [
 367         {
 368           title => 'One Flew Over the Cuckoo's Nest'
 369         }
 370         ]
 371       },
 372       [ 'id' ]
 373     );
 374
 375 This will work with a new DBIC release.
 376
 377 For a many_to_many (pseudo) relation you can supply a list of primary keys
 378 from the other table - and it will link the record at hand to those and
 379 only those records identified by them.  This is convenient for handling web
 380 forms with check boxes (or a SELECT box with multiple choice) that let you
 381 update such (pseudo) relations.
 382
 383 For a description how to set up base classes for ResultSets see load_namespaces
 384 in DBIx::Class::Schema.
 385
 386 =head1 DESIGN CHOICES
 387
 388 =head2 Treatment of many to many pseudo relations
 389
 390 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
 391 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
 392     if($object->can($name) and
 393              !$object->result_source->has_relationship($name) and
 394              $object->can( 'set_' . $name )
 395          )
 396
 397 then $name must be a many to many pseudo relation.  And that in a
 398 similarly ugly was I find out what is the ResultSource of objects from
 399 that many to many pseudo relation.
 400
 401
 402 =head1 INTERFACE
 403
 404 =head1 METHODS
 405
 406 =head2 recursive_update
 407
 408 The method that does the work here.
 409
 410 =head2 is_m2m
 411
 412 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
 413 (pseudo) relation on $self.
 414
 415 =head2 get_m2m_source
 416
 417 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
 418 to many (pseudo) relation 'name' from $self.
 419
 420
 421 =head1 DIAGNOSTICS
 422
 423
 424 =head1 CONFIGURATION AND ENVIRONMENT
 425
 426 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
 427
 428 =head1 DEPENDENCIES
 429
 430     DBIx::Class
 431
 432 =head1 INCOMPATIBILITIES
 433
 434 =for author to fill in:
 435
 436 None reported.
 437
 438
 439 =head1 BUGS AND LIMITATIONS
 440
 441 =for author to fill in:
 442
 443 No bugs have been reported.
 444
 445 Please report any bugs or feature requests to
 446 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
 447 L<http://rt.cpan.org>.
 448
 449
 450 =head1 AUTHOR
 451
 452 Zbigniew Lukasiak  C<< <zby@cpan.org> >>
 453 Influenced by code by Pedro Melo.
 454
 455 =head1 LICENCE AND COPYRIGHT
 456
 457 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
 458
 459 This module is free software; you can redistribute it and/or
 460 modify it under the same terms as Perl itself. See L<perlartistic>.
 461
 462
 463 =head1 DISCLAIMER OF WARRANTY
 464
 465 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 466 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 467 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 468 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 469 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 470 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 471 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 472 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 473 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 474
 475 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 476 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 477 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 478 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 479 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 480 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 481 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 482 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 483 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 484 SUCH DAMAGES.