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