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