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.012';
   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 && ($info->{attrs}{join_type} eq 'LEFT'));
 218         }
 219         $object->set_from_related( $name, $sub_object )
 220           unless (!$sub_object && !$sub_updates && ($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
 320 =head1 VERSION
 321
 322 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.006
 323
 324
 325 =head1 SYNOPSIS
 326
 327 The functional interface:
 328
 329     my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({
 330         resultset => $schema->resultset( 'Dvd' ),
 331         updates => {
 332             id => 1,
 333             owned_dvds => [
 334                 {
 335                   title => 'One Flew Over the Cuckoo's Nest'
 336                 }
 337             ]
 338         }
 339     });
 340
 341
 342 As ResultSet subclass:
 343
 344     __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
 345
 346 in the Schema file (see t/lib/DBSchema.pm).  Or appriopriate 'use base' in the ResultSet classes.
 347
 348 Then:
 349
 350     my $user = $user_rs->recursive_update( {
 351         id => 1,
 352         owned_dvds => [
 353         {
 354           title => 'One Flew Over the Cuckoo's Nest'
 355         }
 356         ]
 357       }
 358     );
 359
 360
 361 =head1 DESCRIPTION
 362 This is still experimental. I've added a functional interface so that it can be used
 363 in Form Processors and not require modification of the model.
 364
 365 You can feed the ->create method with a recursive datastructure and have the related records
 366 created.  Unfortunately you cannot do a similar thing with update_or_create - this module
 367 tries to fill that void.
 368
 369 It is a base class for ResultSets providing just one method: recursive_update
 370 which works just like update_or_create but can recursively update or create
 371 data objects composed of multiple rows. All rows need to be identified by primary keys
 372 - so you need to provide them in the update structure (unless they can be deduced from
 373 the parent row - for example when you have a belongs_to relationship).
 374 If not all colums comprising the primary key are specified - then a new row will be created,
 375 with the expectation that the missing columns will be filled by it (as in the case of auto_increment
 376 primary keys).
 377
 378
 379 If the resultset itself stores an assignement for the primary key,
 380 like in the case of:
 381
 382     my $restricted_rs = $user_rs->search( { id => 1 } );
 383
 384 then you need to inform recursive_update about additional predicate with a second argument:
 385
 386     my $user = $restricted_rs->recursive_update( {
 387         owned_dvds => [
 388         {
 389           title => 'One Flew Over the Cuckoo's Nest'
 390         }
 391         ]
 392       },
 393       [ 'id' ]
 394     );
 395
 396 This will work with a new DBIC release.
 397
 398 For a many_to_many (pseudo) relation you can supply a list of primary keys
 399 from the other table - and it will link the record at hand to those and
 400 only those records identified by them.  This is convenient for handling web
 401 forms with check boxes (or a SELECT box with multiple choice) that let you
 402 update such (pseudo) relations.
 403
 404 For a description how to set up base classes for ResultSets see load_namespaces
 405 in DBIx::Class::Schema.
 406
 407 =head1 DESIGN CHOICES
 408
 409 =head2 Treatment of many to many pseudo relations
 410
 411 The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
 412 If it is not loaded in the ResultSource classes - then the code relies on the fact that:
 413     if($object->can($name) and
 414              !$object->result_source->has_relationship($name) and
 415              $object->can( 'set_' . $name )
 416          )
 417
 418 then $name must be a many to many pseudo relation.  And that in a
 419 similarly ugly was I find out what is the ResultSource of objects from
 420 that many to many pseudo relation.
 421
 422
 423 =head1 INTERFACE
 424
 425 =head1 METHODS
 426
 427 =head2 recursive_update
 428
 429 The method that does the work here.
 430
 431 =head2 is_m2m
 432
 433 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
 434 (pseudo) relation on $self.
 435
 436 =head2 get_m2m_source
 437
 438 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
 439 to many (pseudo) relation 'name' from $self.
 440
 441
 442 =head1 DIAGNOSTICS
 443
 444
 445 =head1 CONFIGURATION AND ENVIRONMENT
 446
 447 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
 448
 449 =head1 DEPENDENCIES
 450
 451     DBIx::Class
 452
 453 =head1 INCOMPATIBILITIES
 454
 455 =for author to fill in:
 456
 457 None reported.
 458
 459
 460 =head1 BUGS AND LIMITATIONS
 461
 462 =for author to fill in:
 463
 464 No bugs have been reported.
 465
 466 Please report any bugs or feature requests to
 467 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
 468 L<http://rt.cpan.org>.
 469
 470
 471 =head1 AUTHOR
 472
 473 Zbigniew Lukasiak  C<< <zby@cpan.org> >>
 474 Influenced by code by Pedro Melo.
 475
 476 =head1 LICENCE AND COPYRIGHT
 477
 478 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
 479
 480 This module is free software; you can redistribute it and/or
 481 modify it under the same terms as Perl itself. See L<perlartistic>.
 482
 483
 484 =head1 DISCLAIMER OF WARRANTY
 485
 486 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 487 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 488 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 489 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 490 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 491 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 492 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 493 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 494 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 495
 496 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 497 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 498 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 499 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 500 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 501 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 502 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 503 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 504 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 505 SUCH DAMAGES.