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