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