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 our $VERSION = '0.013';
   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, $resolved, $if_not_submitted ) = @params{ qw/resultset updates fixed_fields object resolved if_not_submitted/ };
  26     $resolved ||= {};
  27     # warn 'entering: ' . $self->result_source->from();
  28     carp 'fixed fields needs to be an array ref' if $fixed_fields && ref($fixed_fields) ne 'ARRAY';
  29     my %fixed_fields;
  30     %fixed_fields = map { $_ => 1 } @$fixed_fields if $fixed_fields;
  31     if ( blessed($updates) && $updates->isa('DBIx::Class::Row') ) {
  32         return $updates;
  33     }
  34     if ( $updates->{id} ){
  35         $object = $self->find( $updates->{id}, { key => 'primary' } );
  36     }
  37     my @missing =
  38       grep { !exists $updates->{$_} && !exists $fixed_fields{$_} } $self->result_source->primary_columns;
  39     if ( !$object && !scalar @missing ) {
  40 #        warn 'finding by: ' . Dumper( $updates ); use Data::Dumper;
  41         $object = $self->find( $updates, { key => 'primary' } );
  42     }
  43     $updates = { %$updates, %$resolved };
  44     @missing =
  45       grep { !exists $resolved->{$_} } @missing;
  46     if ( !$object && !scalar @missing ) {
  47 #        warn 'finding by +resolved: ' . Dumper( $updates ); use Data::Dumper;
  48         $object = $self->find( $updates, { key => 'primary' } );
  49     }
  50     $object ||= $self->new( {} );
  51     # warn Dumper( $updates ); use Data::Dumper;
  52     # direct column accessors
  53     my %columns;
  54
  55     # relations that that should be done before the row is inserted into the database
  56     # like belongs_to
  57     my %pre_updates;
  58
  59     # relations that that should be done after the row is inserted into the database
  60     # like has_many, might_have and has_one
  61     my %post_updates;
  62     my %other_methods;
  63     my %columns_by_accessor = _get_columns_by_accessor( $self );
  64 #    warn 'resolved: ' . Dumper( $resolved );
  65 #    warn 'updates: ' . Dumper( $updates ); use Data::Dumper;
  66 #    warn 'columns: ' . Dumper( \%columns_by_accessor );
  67     for my $name ( keys %$updates ) {
  68         my $source = $self->result_source;
  69         if ( $columns_by_accessor{$name}
  70             && !( $source->has_relationship($name) && ref( $updates->{$name} ) )
  71           )
  72         {
  73             $columns{$name} = $updates->{$name};
  74             next;
  75         }
  76         if( !( $source->has_relationship($name) ) ){
  77             $other_methods{$name} = $updates->{$name};
  78             next;
  79         }
  80         my $info = $source->relationship_info($name);
  81         if (
  82             _master_relation_cond(
  83                 $source, $info->{cond}, _get_pk_for_related( $self, $name)
  84             )
  85           )
  86         {
  87             $pre_updates{$name} = $updates->{$name};
  88         }
  89         else {
  90             $post_updates{$name} = $updates->{$name};
  91         }
  92     }
  93     # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
  94
  95     # first update columns and other accessors - so that later related records can be found
  96     for my $name ( keys %columns ) {
  97         $object->$name( $columns{$name} );
  98     }
  99     for my $name ( keys %other_methods) {
 100         $object->$name( $updates->{$name} ) if $object->can( $name );
 101     }
 102     for my $name ( keys %pre_updates ) {
 103         my $info = $object->result_source->relationship_info($name);
 104         _update_relation( $self, $name, $updates, $object, $info, $if_not_submitted );
 105     }
 106 #    $self->_delete_empty_auto_increment($object);
 107 # don't allow insert to recurse to related objects - we do the recursion ourselves
 108 #    $object->{_rel_in_storage} = 1;
 109
 110     $object->update_or_insert if $object->is_changed;
 111
 112     # updating many_to_many
 113     for my $name ( keys %$updates ) {
 114         next if exists $columns{$name};
 115         my $value = $updates->{$name};
 116
 117         if ( is_m2m( $self, $name) ) {
 118             my ($pk) = _get_pk_for_related( $self, $name);
 119             my @rows;
 120             my $result_source = $object->$name->result_source;
 121             my @updates;
 122             if( ! defined $value ){
 123                 next;
 124             }
 125             elsif( ref $value ){
 126                 @updates = @{ $value };
 127             }
 128             else{
 129                 @updates = ( $value );
 130             }
 131             for my $elem ( @updates ) {
 132                 if ( ref $elem ) {
 133                     push @rows, recursive_update( resultset => $result_source->resultset, updates => $elem );
 134                 }
 135                 else {
 136                     push @rows,
 137                       $result_source->resultset->find( { $pk => $elem } );
 138                 }
 139             }
 140             my $set_meth = 'set_' . $name;
 141             $object->$set_meth( \@rows );
 142         }
 143     }
 144     for my $name ( keys %post_updates ) {
 145         my $info = $object->result_source->relationship_info($name);
 146         _update_relation( $self, $name, $updates, $object, $info, $if_not_submitted );
 147     }
 148     return $object;
 149 }
 150
 151 # returns DBIx::Class::ResultSource::column_info as a hash indexed by column accessor || name
 152 sub _get_columns_by_accessor {
 153     my $self   = shift;
 154     my $source = $self->result_source;
 155     my %columns;
 156     for my $name ( $source->columns ) {
 157         my $info = $source->column_info($name);
 158         $info->{name} = $name;
 159         $columns{ $info->{accessor} || $name } = $info;
 160     }
 161     return %columns;
 162 }
 163
 164 sub _update_relation {
 165     my ( $self, $name, $updates, $object, $info, $if_not_submitted ) = @_;
 166     my $related_result =
 167       $self->related_resultset($name)->result_source->resultset;
 168     my $resolved;
 169     if( $self->result_source->can( '_resolve_condition' ) ){
 170         $resolved = $self->result_source->_resolve_condition( $info->{cond}, $name, $object );
 171     }
 172     else{
 173         $resolved = $self->result_source->resolve_condition( $info->{cond}, $name, $object );
 174     }
 175
 176  #                    warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
 177     $resolved = {}
 178       if defined $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION && $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION == $resolved;
 179     if ( ref $updates->{$name} eq 'ARRAY' ) {
 180         my @updated_ids;
 181         for my $sub_updates ( @{ $updates->{$name} } ) {
 182             my $sub_object =
 183               recursive_update( resultset => $related_result, updates => $sub_updates, resolved => $resolved );
 184             push @updated_ids, $sub_object->id;
 185         }
 186         my @related_pks = $related_result->result_source->primary_columns;
 187         if( defined $if_not_submitted && $if_not_submitted eq 'delete' ){
 188             # only handles related result classes with single primary keys
 189             if ( 1 == scalar @related_pks ){
 190                 $object->$name->search( { $related_pks[0] => { -not_in => \@updated_ids } } )->delete;
 191             }
 192         }
 193         elsif( defined $if_not_submitted && $if_not_submitted eq 'set_to_null' ){
 194             # only handles related result classes with single primary keys
 195             if ( 1 == scalar @related_pks ){
 196                 my @fk = keys %$resolved;
 197                 $object->$name->search( { $related_pks[0] => { -not_in => \@updated_ids } } )->update( { $fk[0] => undef } );
 198             }
 199         }
 200     }
 201     else {
 202         my $sub_updates = $updates->{$name};
 203         my $sub_object;
 204         if( ref $sub_updates ){
 205             # for might_have relationship
 206             if( $info->{attrs}{accessor} eq 'single' && defined $object->$name ){
 207                 $sub_object = recursive_update(
 208                     resultset => $related_result,
 209                     updates => $sub_updates,
 210                     object =>  $object->$name
 211                 );
 212             }
 213             else{
 214                 $sub_object =
 215                 recursive_update( resultset => $related_result, updates => $sub_updates, resolved => $resolved );
 216             }
 217         }
 218         elsif( ! ref $sub_updates ){
 219             $sub_object = $related_result->find( $sub_updates )
 220                 unless (!$sub_updates && (exists $info->{attrs}{join_type} && $info->{attrs}{join_type} eq 'LEFT'));
 221         }
 222         $object->set_from_related( $name, $sub_object )
 223           unless (!$sub_object && !$sub_updates && (exists $info->{attrs}{join_type} && $info->{attrs}{join_type} eq 'LEFT'));
 224     }
 225 }
 226
 227 sub is_m2m {
 228     my ( $self, $relation ) = @_;
 229     my $rclass = $self->result_class;
 230
 231     # DBIx::Class::IntrospectableM2M
 232     if ( $rclass->can('_m2m_metadata') ) {
 233         return $rclass->_m2m_metadata->{$relation};
 234     }
 235     my $object = $self->new( {} );
 236     if (    $object->can($relation)
 237         and !$self->result_source->has_relationship($relation)
 238         and $object->can( 'set_' . $relation ) )
 239     {
 240         return 1;
 241     }
 242     return;
 243 }
 244
 245 sub get_m2m_source {
 246     my ( $self, $relation ) = @_;
 247     my $rclass = $self->result_class;
 248
 249     # DBIx::Class::IntrospectableM2M
 250     if ( $rclass->can('_m2m_metadata') ) {
 251         return $self->result_source->related_source(
 252             $rclass->_m2m_metadata->{$relation}{relation} )
 253           ->related_source(
 254             $rclass->_m2m_metadata->{$relation}{foreign_relation} );
 255     }
 256     my $object = $self->new( {} );
 257     my $r = $object->$relation;
 258     return $r->result_source;
 259 }
 260
 261 sub _delete_empty_auto_increment {
 262     my ( $self, $object ) = @_;
 263     for my $col ( keys %{ $object->{_column_data} } ) {
 264         if (
 265             $object->result_source->column_info($col)->{is_auto_increment}
 266             and ( !defined $object->{_column_data}{$col}
 267                 or $object->{_column_data}{$col} eq '' )
 268           )
 269         {
 270             delete $object->{_column_data}{$col};
 271         }
 272     }
 273 }
 274
 275 sub _get_pk_for_related {
 276     my ( $self, $relation ) = @_;
 277     my $result_source;
 278     if ( $self->result_source->has_relationship($relation) ) {
 279         $result_source = $self->result_source->related_source($relation);
 280     }
 281
 282     # many to many case
 283     if ( is_m2m($self, $relation) ) {
 284         $result_source = get_m2m_source($self, $relation);
 285     }
 286     return $result_source->primary_columns;
 287 }
 288
 289 # This function determines wheter a relationship should be done before or
 290 # after the row is inserted into the database
 291 # relationships before: belongs_to
 292 # relationships after: has_many, might_have and has_one
 293 sub _master_relation_cond {
 294     my ( $source, $cond, @foreign_ids ) = @_;
 295     my $foreign_ids_re = join '|', @foreign_ids;
 296     if ( ref $cond eq 'HASH' ) {
 297         for my $f_key ( keys %{$cond} ) {
 298
 299             # might_have is not master
 300             my $col = $cond->{$f_key};
 301             $col =~ s/self\.//;
 302             if ( $source->column_info($col)->{is_auto_increment} ) {
 303                 return 0;
 304             }
 305             if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
 306                 return 1;
 307             }
 308         }
 309     }
 310     elsif ( ref $cond eq 'ARRAY' ) {
 311         for my $new_cond (@$cond) {
 312             return 1
 313               if _master_relation_cond( $source, $new_cond, @foreign_ids );
 314         }
 315     }
 316     return;
 317 }
 318
 319 1;    # Magic true value required at end of module
 320 __END__
 321
 322 =head1 NAME
 323
 324 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
 325
 326 =head1 SYNOPSIS
 327
 328 The functional interface:
 329
 330     my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
 331         resultset => $schema->resultset( 'Dvd' ),
 332         updates => {
 333             id => 1,
 334             owned_dvds => [
 335                 {
 336                   title => 'One Flew Over the Cuckoo's Nest'
 337                 }
 338             ]
 339         }
 340     });
 341
 342
 343 As ResultSet subclass:
 344
 345     __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
 346
 347 in the Schema file (see t/lib/DBSchema.pm).  Or appriopriate 'use base' in the ResultSet classes.
 348
 349 Then:
 350
 351     my $user = $user_rs->recursive_update( {
 352         id => 1,
 353         owned_dvds => [
 354         {
 355           title => 'One Flew Over the Cuckoo's Nest'
 356         }
 357         ]
 358       }
 359     );
 360
 361
 362 =head1 DESCRIPTION
 363
 364 This is still experimental. I've added a functional interface so that it can be used
 365 in Form Processors and not require modification of the model.
 366
 367 You can feed the ->create method with a recursive datastructure and have the related records
 368 created.  Unfortunately you cannot do a similar thing with update_or_create - this module
 369 tries to fill that void.
 370
 371 It is a base class for ResultSets providing just one method: recursive_update
 372 which works just like update_or_create but can recursively update or create
 373 data objects composed of multiple rows. All rows need to be identified by primary keys
 374 - so you need to provide them in the update structure (unless they can be deduced from
 375 the parent row - for example when you have a belongs_to relationship).
 376 If not all colums comprising the primary key are specified - then a new row will be created,
 377 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
 378 primary keys).
 379
 380
 381 If the resultset itself stores an assignement for the primary key,
 382 like in the case of:
 383
 384     my $restricted_rs = $user_rs->search( { id => 1 } );
 385
 386 then you need to inform recursive_update about additional predicate with a second argument:
 387
 388     my $user = $restricted_rs->recursive_update( {
 389         owned_dvds => [
 390         {
 391           title => 'One Flew Over the Cuckoo's Nest'
 392         }
 393         ]
 394       },
 395       [ 'id' ]
 396     );
 397
 398 This will work with a new DBIC release.
 399
 400 For a many_to_many (pseudo) relation you can supply a list of primary keys
 401 from the other table - and it will link the record at hand to those and
 402 only those records identified by them.  This is convenient for handling web
 403 forms with check boxes (or a SELECT box with multiple choice) that let you
 404 update such (pseudo) relations.
 405
 406 For a description how to set up base classes for ResultSets see load_namespaces
 407 in DBIx::Class::Schema.
 408
 409 =head1 DESIGN CHOICES
 410
 411 Columns and relationships which are excluded from the updates hashref aren't
 412 touched at all.
 413
 414 =head2 Treatment of belongs_to relations
 415
 416 In case the relationship is included but undefined in the updates hashref,
 417 all columns forming the relationship will be set to null.
 418 If not all of them are nullable, DBIx::Class will throw an error.
 419
 420 Updating the relationship:
 421
 422     my $dvd = $dvd_rs->recursive_update( {
 423         id    => 1,
 424         owner => $user->id,
 425     });
 426
 427 Clearing the relationship (only works if cols are nullable!):
 428
 429     my $dvd = $dvd_rs->recursive_update( {
 430         id    => 1,
 431         owner => undef,
 432     });
 433
 434 =head2 Treatment of might_have relationships
 435
 436 In case the relationship is included but undefined in the updates hashref,
 437 all columns forming the relationship will be set to null.
 438
 439 Updating the relationship:
 440
 441     my $user = $user_rs->recursive_update( {
 442         id => 1,
 443         address => {
 444             street => "101 Main Street",
 445             city   => "Podunk",
 446             state  => "New York",
 447         }
 448     });
 449
 450 Clearing the relationship:
 451
 452     my $user = $user_rs->recursive_update( {
 453         id => 1,
 454         address => undef,
 455     });
 456
 457 =head2 Treatment of has_many relations
 458
 459 If a relationship key is included in the data structure with a value of undef
 460 or an empty array, all existing related rows will be deleted, or their foreign
 461 key columns will be set to null.
 462
 463 The exact behaviour depends on the nullability of the foreign key columns and
 464 the value of the "if_not_submitted" parameter. The parameter defaults to
 465 undefined which neither nullifies nor deletes.
 466
 467 When the array contains elements they are updated if they exist, created when
 468 not and deleted if not included.
 469
 470 =head3 All foreign table columns are nullable
 471
 472 In this case recursive_update defaults to nullifying the foreign columns.
 473
 474 =head3 Not all foreign table columns are nullable
 475
 476 In this case recursive_update deletes the foreign rows.
 477
 478 Updating the relationship:
 479
 480     Passing ids:
 481
 482     my $dvd = $dvd_rs->recursive_update( {
 483         id   => 1,
 484         tags => [1, 2],
 485     });
 486
 487     Passing hashrefs:
 488
 489     my $dvd = $dvd_rs->recursive_update( {
 490         id   => 1,
 491         tags => [
 492             {
 493                 id   => 1,
 494                 file => 'file0'
 495             },
 496             {
 497                 id   => 2,
 498                 file => 'file1',
 499             },
 500         ],
 501     });
 502
 503     Passing objects:
 504
 505     TODO
 506
 507     You can even mix them:
 508
 509     my $dvd = $dvd_rs->recursive_update( {
 510         id   => 1,
 511         tags => [ '2', { id => '3' } ],
 512     });
 513
 514 Clearing the relationship:
 515
 516     my $dvd = $dvd_rs->recursive_update( {
 517         id   => 1,
 518         tags => undef,
 519     });
 520
 521     This is the same as passing an empty array:
 522
 523     my $dvd = $dvd_rs->recursive_update( {
 524         id   => 1,
 525         tags => [],
 526     });
 527
 528 =head2 Treatment of many-to-many pseudo relations
 529
 530 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
 531 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
 532     if($object->can($name) and
 533              !$object->result_source->has_relationship($name) and
 534              $object->can( 'set_' . $name )
 535          )
 536
 537 then $name must be a many to many pseudo relation.  And that in a
 538 similarly ugly was I find out what is the ResultSource of objects from
 539 that many to many pseudo relation.
 540
 541
 542 =head1 INTERFACE
 543
 544 =head1 METHODS
 545
 546 =head2 recursive_update
 547
 548 The method that does the work here.
 549
 550 =head2 is_m2m
 551
 552 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
 553 (pseudo) relation on $self.
 554
 555 =head2 get_m2m_source
 556
 557 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
 558 to many (pseudo) relation 'name' from $self.
 559
 560
 561 =head1 DIAGNOSTICS
 562
 563
 564 =head1 CONFIGURATION AND ENVIRONMENT
 565
 566 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
 567
 568 =head1 DEPENDENCIES
 569
 570     DBIx::Class
 571
 572 =head1 INCOMPATIBILITIES
 573
 574 None reported.
 575
 576
 577 =head1 BUGS AND LIMITATIONS
 578
 579 No bugs have been reported.
 580
 581 Please report any bugs or feature requests to
 582 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
 583 L<http://rt.cpan.org>.
 584
 585
 586 =head1 AUTHOR
 587
 588 Zbigniew Lukasiak  C<< <zby@cpan.org> >>
 589 Influenced by code by Pedro Melo.
 590
 591 =head1 LICENCE AND COPYRIGHT
 592
 593 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
 594
 595 This module is free software; you can redistribute it and/or
 596 modify it under the same terms as Perl itself. See L<perlartistic>.
 597
 598
 599 =head1 DISCLAIMER OF WARRANTY
 600
 601 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 602 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 603 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 604 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 605 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 606 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 607 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 608 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 609 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 610
 611 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 612 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 613 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 614 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 615 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 616 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 617 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 618 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 619 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 620 SUCH DAMAGES.