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