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

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