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