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