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.011';
   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 and might_have
  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;
 111
 112
 113     # updating many_to_many
 114     for my $name ( keys %$updates ) {
 115         next if exists $columns{$name};
 116         my $value = $updates->{$name};
 117
 118         if ( is_m2m( $self, $name) ) {
 119             my ($pk) = _get_pk_for_related( $self, $name);
 120             my @rows;
 121             my $result_source = $object->$name->result_source;
 122             my @updates;
 123             if( ! defined $value ){
 124                 next;
 125             }
 126             elsif( ref $value ){
 127                 @updates = @{ $value };
 128             }
 129             else{
 130                 @updates = ( $value );
 131             }
 132             for my $elem ( @updates ) {
 133                 if ( ref $elem ) {
 134                     push @rows, recursive_update( resultset => $result_source->resultset, updates => $elem );
 135                 }
 136                 else {
 137                     push @rows,
 138                       $result_source->resultset->find( { $pk => $elem } );
 139                 }
 140             }
 141             my $set_meth = 'set_' . $name;
 142             $object->$set_meth( \@rows );
 143         }
 144     }
 145     for my $name ( keys %post_updates ) {
 146         my $info = $object->result_source->relationship_info($name);
 147         _update_relation( $self, $name, $updates, $object, $info, $if_not_submitted );
 148     }
 149     return $object;
 150 }
 151
 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             if ( 1 == scalar @related_pks ){
 189                 $object->$name->search( { $related_pks[0] => { -not_in => \@updated_ids } } )->delete;
 190             }
 191         }
 192         elsif( defined $if_not_submitted && $if_not_submitted eq 'set_to_null' ){
 193             if ( 1 == scalar @related_pks ){
 194                 my @fk = keys %$resolved;
 195                 $object->$name->search( { $related_pks[0] => { -not_in => \@updated_ids } } )->update( { $fk[0] => undef } );
 196             }
 197         }
 198     }
 199     else {
 200         my $sub_updates = $updates->{$name};
 201         my $sub_object;
 202         if( ref $sub_updates ){
 203             # for might_have relationship
 204             if( $info->{attrs}{accessor} eq 'single' && defined $object->$name ){
 205                 $sub_object = recursive_update(
 206                     resultset => $related_result,
 207                     updates => $sub_updates,
 208                     object =>  $object->$name
 209                 );
 210             }
 211             else{
 212                 $sub_object =
 213                 recursive_update( resultset => $related_result, updates => $sub_updates, resolved => $resolved );
 214             }
 215         }
 216         elsif( ! ref $sub_updates ){
 217             $sub_object = $related_result->find( $sub_updates );
 218         }
 219         $object->set_from_related( $name, $sub_object );
 220     }
 221 }
 222
 223 sub is_m2m {
 224     my ( $self, $relation ) = @_;
 225     my $rclass = $self->result_class;
 226
 227     # DBIx::Class::IntrospectableM2M
 228     if ( $rclass->can('_m2m_metadata') ) {
 229         return $rclass->_m2m_metadata->{$relation};
 230     }
 231     my $object = $self->new( {} );
 232     if (    $object->can($relation)
 233         and !$self->result_source->has_relationship($relation)
 234         and $object->can( 'set_' . $relation ) )
 235     {
 236         return 1;
 237     }
 238     return;
 239 }
 240
 241 sub get_m2m_source {
 242     my ( $self, $relation ) = @_;
 243     my $rclass = $self->result_class;
 244
 245     # DBIx::Class::IntrospectableM2M
 246     if ( $rclass->can('_m2m_metadata') ) {
 247         return $self->result_source->related_source(
 248             $rclass->_m2m_metadata->{$relation}{relation} )
 249           ->related_source(
 250             $rclass->_m2m_metadata->{$relation}{foreign_relation} );
 251     }
 252     my $object = $self->new( {} );
 253     my $r = $object->$relation;
 254     return $r->result_source;
 255 }
 256
 257 sub _delete_empty_auto_increment {
 258     my ( $self, $object ) = @_;
 259     for my $col ( keys %{ $object->{_column_data} } ) {
 260         if (
 261             $object->result_source->column_info($col)->{is_auto_increment}
 262             and ( !defined $object->{_column_data}{$col}
 263                 or $object->{_column_data}{$col} eq '' )
 264           )
 265         {
 266             delete $object->{_column_data}{$col};
 267         }
 268     }
 269 }
 270
 271 sub _get_pk_for_related {
 272     my ( $self, $relation ) = @_;
 273     my $result_source;
 274     if ( $self->result_source->has_relationship($relation) ) {
 275         $result_source = $self->result_source->related_source($relation);
 276     }
 277
 278     # many to many case
 279     if ( is_m2m($self, $relation) ) {
 280         $result_source = get_m2m_source($self, $relation);
 281     }
 282     return $result_source->primary_columns;
 283 }
 284
 285 sub _master_relation_cond {
 286     my ( $source, $cond, @foreign_ids ) = @_;
 287     my $foreign_ids_re = join '|', @foreign_ids;
 288     if ( ref $cond eq 'HASH' ) {
 289         for my $f_key ( keys %{$cond} ) {
 290
 291             # might_have is not master
 292             my $col = $cond->{$f_key};
 293             $col =~ s/self\.//;
 294             if ( $source->column_info($col)->{is_auto_increment} ) {
 295                 return 0;
 296             }
 297             if ( $f_key =~ /^foreign\.$foreign_ids_re/ ) {
 298                 return 1;
 299             }
 300         }
 301     }
 302     elsif ( ref $cond eq 'ARRAY' ) {
 303         for my $new_cond (@$cond) {
 304             return 1
 305               if _master_relation_cond( $source, $new_cond, @foreign_ids );
 306         }
 307     }
 308     return;
 309 }
 310
 311 1;    # Magic true value required at end of module
 312 __END__
 313
 314 =head1 NAME
 315
 316 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
 317
 318
 319 =head1 VERSION
 320
 321 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.006
 322
 323
 324 =head1 SYNOPSIS
 325
 326 The functional interface:
 327
 328     my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
 329         resultset => $schema->resultset( 'Dvd' ),
 330         updates => {
 331             id => 1,
 332             owned_dvds => [
 333                 {
 334                   title => 'One Flew Over the Cuckoo's Nest'
 335                 }
 336             ]
 337         }
 338     });
 339
 340
 341 As ResultSet subclass:
 342
 343     __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
 344
 345 in the Schema file (see t/lib/DBSchema.pm).  Or appriopriate 'use base' in the ResultSet classes.
 346
 347 Then:
 348
 349     my $user = $user_rs->recursive_update( {
 350         id => 1,
 351         owned_dvds => [
 352         {
 353           title => 'One Flew Over the Cuckoo's Nest'
 354         }
 355         ]
 356       }
 357     );
 358
 359
 360 =head1 DESCRIPTION
 361 This is still experimental. I've added a functional interface so that it can be used
 362 in Form Processors and not require modification of the model.
 363
 364 You can feed the ->create method with a recursive datastructure and have the related records
 365 created.  Unfortunately you cannot do a similar thing with update_or_create - this module
 366 tries to fill that void.
 367
 368 It is a base class for ResultSets providing just one method: recursive_update
 369 which works just like update_or_create but can recursively update or create
 370 data objects composed of multiple rows. All rows need to be identified by primary keys
 371 - so you need to provide them in the update structure (unless they can be deduced from
 372 the parent row - for example when you have a belongs_to relationship).
 373 If not all colums comprising the primary key are specified - then a new row will be created,
 374 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
 375 primary keys).
 376
 377
 378 If the resultset itself stores an assignement for the primary key,
 379 like in the case of:
 380
 381     my $restricted_rs = $user_rs->search( { id => 1 } );
 382
 383 then you need to inform recursive_update about additional predicate with a second argument:
 384
 385     my $user = $restricted_rs->recursive_update( {
 386         owned_dvds => [
 387         {
 388           title => 'One Flew Over the Cuckoo's Nest'
 389         }
 390         ]
 391       },
 392       [ 'id' ]
 393     );
 394
 395 This will work with a new DBIC release.
 396
 397 For a many_to_many (pseudo) relation you can supply a list of primary keys
 398 from the other table - and it will link the record at hand to those and
 399 only those records identified by them.  This is convenient for handling web
 400 forms with check boxes (or a SELECT box with multiple choice) that let you
 401 update such (pseudo) relations.
 402
 403 For a description how to set up base classes for ResultSets see load_namespaces
 404 in DBIx::Class::Schema.
 405
 406 =head1 DESIGN CHOICES
 407
 408 =head2 Treatment of many to many pseudo relations
 409
 410 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
 411 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
 412     if($object->can($name) and
 413              !$object->result_source->has_relationship($name) and
 414              $object->can( 'set_' . $name )
 415          )
 416
 417 then $name must be a many to many pseudo relation.  And that in a
 418 similarly ugly was I find out what is the ResultSource of objects from
 419 that many to many pseudo relation.
 420
 421
 422 =head1 INTERFACE
 423
 424 =head1 METHODS
 425
 426 =head2 recursive_update
 427
 428 The method that does the work here.
 429
 430 =head2 is_m2m
 431
 432 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
 433 (pseudo) relation on $self.
 434
 435 =head2 get_m2m_source
 436
 437 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
 438 to many (pseudo) relation 'name' from $self.
 439
 440
 441 =head1 DIAGNOSTICS
 442
 443
 444 =head1 CONFIGURATION AND ENVIRONMENT
 445
 446 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
 447
 448 =head1 DEPENDENCIES
 449
 450     DBIx::Class
 451
 452 =head1 INCOMPATIBILITIES
 453
 454 =for author to fill in:
 455
 456 None reported.
 457
 458
 459 =head1 BUGS AND LIMITATIONS
 460
 461 =for author to fill in:
 462
 463 No bugs have been reported.
 464
 465 Please report any bugs or feature requests to
 466 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
 467 L<http://rt.cpan.org>.
 468
 469
 470 =head1 AUTHOR
 471
 472 Zbigniew Lukasiak  C<< <zby@cpan.org> >>
 473 Influenced by code by Pedro Melo.
 474
 475 =head1 LICENCE AND COPYRIGHT
 476
 477 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
 478
 479 This module is free software; you can redistribute it and/or
 480 modify it under the same terms as Perl itself. See L<perlartistic>.
 481
 482
 483 =head1 DISCLAIMER OF WARRANTY
 484
 485 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 486 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 487 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 488 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 489 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 490 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 491 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 492 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 493 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 494
 495 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 496 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 497 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 498 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 499 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 500 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 501 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 502 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 503 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 504 SUCH DAMAGES.