Dogcows Code - chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate/blob - lib/DBIx/Class/ResultSet/RecursiveUpdate.pm

   1 package DBIx::Class::ResultSet::RecursiveUpdate;
   2
   3 use version; $VERSION = qv('0.001');
   4
   5 use warnings;
   6 use strict;
   7 use Carp;
   8 use Scalar::Util qw( blessed );
   9
  10 use base qw(DBIx::Class::ResultSet);
  11
  12 sub recursive_update {
  13     my( $self, $updates, $fixed_fields ) = @_;
  14     # warn 'entering: ' . $self->result_source->from();
  15     if( blessed( $updates ) && $updates->isa( 'DBIx::Class::Row' ) ){
  16         return $updates;
  17     }
  18     if( $fixed_fields ){
  19         carp if !( ref( $fixed_fields ) eq 'HASH' );
  20         $updates = { %$updates, %$fixed_fields };
  21     }
  22     # direct column accessors
  23     my %columns;
  24
  25     # relations that that should be done before the row is inserted into the database
  26     # like belongs_to
  27     my %pre_updates;
  28
  29     # relations that that should be done after the row is inserted into the database
  30     # like has_many and might_have
  31     my %post_updates;
  32     for my $name ( keys %$updates ){
  33         my $source = $self->result_source;
  34         if( $source->has_column($name)
  35             && !( $source->has_relationship($name) && ref( $updates->{$name} ) )
  36         ){
  37             $columns{$name} = $updates->{$name};
  38             next;
  39         }
  40         next if ! $source->has_relationship($name);
  41         my $info = $source->relationship_info( $name );
  42         if( _master_relation_cond( $source, $info->{cond}, $self->_get_pk_for_related( $name ) ) ){
  43             $pre_updates{$name} = $updates->{$name};
  44         }
  45         else{
  46             $post_updates{$name} = $updates->{$name};
  47         }
  48     }
  49     # warn 'columns: ' . Dumper( \%columns ); use Data::Dumper;
  50
  51     my $object;
  52     my @missing = grep { !exists $columns{$_} } $self->result_source->primary_columns;
  53     if( ! scalar @missing ){
  54         $object = $self->find( \%columns, { key => 'primary' } );
  55     }
  56     $object ||= $self->new( {} );
  57
  58     # first update columns and other accessors - so that later related records can be found
  59     for my $name ( keys %columns ){
  60         $object->$name( $updates->{$name} );
  61     }
  62     for my $name ( keys %pre_updates ){
  63         my $info = $object->result_source->relationship_info( $name );
  64         $self->update_relation( $name, $updates, $object, $info );
  65     }
  66     $self->_delete_empty_auto_increment($object);
  67 # don't allow insert to recurse to related objects - we do the recursion ourselves
  68 #    $object->{_rel_in_storage} = 1;
  69     $object->update_or_insert;
  70
  71     # updating many_to_many
  72     for my $name ( keys %$updates ){
  73         next if exists $columns{ $name };
  74         my $value = $updates->{$name};
  75         # many to many case
  76         if( $self->is_m2m( $name ) ) {
  77                 my ( $pk ) = $self->_get_pk_for_related( $name );
  78                 my @rows;
  79                 my $result_source = $object->$name->result_source;
  80                 for my $elem ( @{$updates->{$name}} ){
  81                     if( ref $elem ){
  82                         push @rows, $result_source->resultset->find( $elem );
  83                     }
  84                     else{
  85                         push @rows, $result_source->resultset->find( { $pk => $elem } );
  86                     }
  87                 }
  88                 my $set_meth = 'set_' . $name;
  89                 $object->$set_meth( \@rows );
  90         }
  91     }
  92     for my $name ( keys %post_updates ){
  93         my $info = $object->result_source->relationship_info( $name );
  94         $self->update_relation( $name, $updates, $object, $info );
  95     }
  96     return $object;
  97 }
  98
  99 sub update_relation{
 100     my( $self, $name, $updates, $object, $info ) = @_;
 101
 102                     my $related_result = $self->related_resultset( $name )->result_source->resultset;
 103                     my $resolved =  $self->result_source->resolve_condition(
 104                         $info->{cond}, $name, $object
 105                     );
 106 #                    warn 'resolved: ' . Dumper( $resolved ); use Data::Dumper;
 107                     $resolved = undef if $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION == $resolved;
 108                     if( ref $updates->{$name} eq 'ARRAY' ){
 109                         for my $sub_updates ( @{$updates->{$name}} ) {
 110                             my $sub_object = $related_result->recursive_update( $sub_updates, $resolved );
 111                         }
 112                     }
 113                     else {
 114                         my $sub_object = $related_result->recursive_update( $updates->{$name}, $resolved );
 115                         $object->set_from_related( $name, $sub_object );
 116                     }
 117 }
 118
 119
 120 sub is_m2m {
 121     my( $self, $relation ) = @_;
 122     my $rclass = $self->result_class;
 123     # DBIx::Class::IntrospectableM2M
 124     if( $rclass->can( '_m2m_metadata' ) ){
 125         return $rclass->_m2m_metadata->{$relation};
 126     }
 127     my $object = $self->new({});
 128     if ( $object->can($relation) and
 129         !$self->result_source->has_relationship($relation) and
 130         $object->can( 'set_' . $relation)
 131     ){
 132         return 1;
 133     }
 134     return;
 135 }
 136
 137 sub get_m2m_source {
 138     my( $self, $relation ) = @_;
 139     my $rclass = $self->result_class;
 140     # DBIx::Class::IntrospectableM2M
 141     if( $rclass->can( '_m2m_metadata' ) ){
 142         return $self->result_source
 143         ->related_source(
 144             $rclass->_m2m_metadata->{$relation}{relation}
 145         )
 146         ->related_source(
 147             $rclass->_m2m_metadata->{$relation}{foreign_relation}
 148         );
 149     }
 150     my $object = $self->new({});
 151     my $r = $object->$relation;
 152     return $r->result_source;
 153 }
 154
 155
 156 sub _delete_empty_auto_increment {
 157     my ( $self, $object ) = @_;
 158     for my $col ( keys %{$object->{_column_data}}){
 159         if( $object->result_source->column_info( $col )->{is_auto_increment}
 160                 and
 161             ( ! defined $object->{_column_data}{$col} or $object->{_column_data}{$col} eq '' )
 162         ){
 163             delete $object->{_column_data}{$col}
 164         }
 165     }
 166 }
 167
 168 sub _get_pk_for_related {
 169     my ( $self, $relation ) = @_;
 170     my $result_source;
 171     if( $self->result_source->has_relationship( $relation ) ){
 172         $result_source = $self->result_source->related_source( $relation );
 173     }
 174     # many to many case
 175     if ( $self->is_m2m( $relation ) ) {
 176         $result_source = $self->get_m2m_source( $relation );
 177     }
 178     return $result_source->primary_columns;
 179 }
 180
 181 sub _master_relation_cond {
 182     my ( $source, $cond, @foreign_ids ) = @_;
 183     my $foreign_ids_re = join '|', @foreign_ids;
 184     if ( ref $cond eq 'HASH' ){
 185         for my $f_key ( keys %{$cond} ) {
 186             # might_have is not master
 187             my $col = $cond->{$f_key};
 188             $col =~ s/self\.//;
 189             if( $source->column_info( $col )->{is_auto_increment} ){
 190                 return 0;
 191             }
 192             if( $f_key =~ /^foreign\.$foreign_ids_re/ ){
 193                 return 1;
 194             }
 195         }
 196     }elsif ( ref $cond eq 'ARRAY' ){
 197         for my $new_cond ( @$cond ) {
 198             return 1 if _master_relation_cond( $source, $new_cond, @foreign_ids );
 199         }
 200     }
 201     return;
 202 }
 203
 204 1; # Magic true value required at end of module
 205 __END__
 206
 207 =head1 NAME
 208
 209 DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
 210
 211
 212 =head1 VERSION
 213
 214 This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.001
 215
 216
 217 =head1 SYNOPSIS
 218
 219     __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
 220
 221 in the Schema file (see t/lib/DBSchema.pm).  Or appriopriate 'use base' in the ResultSet classes.
 222
 223 Then:
 224
 225     my $user = $user_rs->recursive_update( {
 226         id => 1,
 227         owned_dvds => [
 228         {
 229           id => undef,
 230           title => 'One Flew Over the Cuckoo's Nest'
 231         }
 232         ]
 233       }
 234     );
 235
 236
 237 =head1 DESCRIPTION
 238
 239 You can feed the ->create method with a recursive datastructure and have the related records
 240 created.  Unfortunately you cannot do a similar thing with update_or_create - this module
 241 tries to fill that void.
 242
 243 It is a base class for ResultSets providing just one method: recursive_update
 244 which works just like update_or_create but can recursively update or create
 245 data objects composed of multiple rows. All rows need to be identified by primary keys
 246 - so you need to provide them in the update structure (unless they can be deduced from
 247 the parent row - for example when you have a belongs_to relationship).
 248 When creating new rows in a table with auto_increment primary keys you need to
 249 put 'undef' for the key value - this is then removed
 250 and a correct INSERT statement is generated.
 251
 252 For a many_to_many (pseudo) relation you can supply a list of primary keys
 253 from the other table - and it will link the record at hand to those and
 254 only those records identified by them.  This is convenient for handling web
 255 forms with check boxes (or a SELECT box with multiple choice) that let you
 256 update such (pseudo) relations.
 257
 258 For a description how to set up base classes for ResultSets see load_namespaces
 259 in DBIx::Class::Schema.
 260
 261 =head1 DESIGN CHOICES
 262
 263 =head2 Treatment of many to many pseudo relations
 264
 265 Matt Trout expressed following criticism of the support for many to many in
 266 RecursiveUpdate and since this is an extension of his DBIx::Class I feel obliged to
 267 reply to it.  It is about two points leading in his opinion to 'fragile and
 268 implicitely broken code'.
 269
 270 1. That I rely on the fact that
 271
 272  if($object->can($name) and
 273              !$object->result_source->has_relationship($name) and
 274              $object->can( 'set_' . $name )
 275          )
 276
 277 then $name must be a many to many pseudo relation.  And that in a
 278 similarly ugly was I find out what is the ResultSource of objects from
 279 that many to many pseudo relation.
 280
 281 2. That I treat uniformly relations and many to many (which are
 282 different from relations because they require traversal of the bridge
 283 table).
 284
 285 To answer 1) I've refactored that 'dirty' code into is_m2m and get_m2m_source so
 286 that it can be easily overridden.  I agree that this code is not too nice - but
 287 currenlty it is the only way to do what I need - and I'll replace it as soon as
 288 there is a more clean way.  I don't think it is extremely brittle - sure it will
 289 break if many to many (pseudo) relations don't get 'set_*' methods anymore - but
 290 I would say it is rather justified for this kind of change in underlying library
 291 to break it.
 292
 293
 294 Ad 2) - first this is not strictly true - RecursiveUpdate does have
 295 different code to cope with m2m and other cases (see the point above for
 296 example) - but it let's the user to treat m2m and 'normal' relations in a
 297 uniform way.  I consider this a form of abstraction - it is the work that
 298 RecursiveUpdate does for the programmer.
 299
 300
 301 =head1 INTERFACE
 302
 303 =head1 METHODS
 304
 305 =head2 recursive_update
 306
 307 The method that does the work here.
 308
 309 =head2 is_m2m
 310
 311 $self->is_m2m( 'name ' ) - answers the question if 'name' is a many to many
 312 (pseudo) relation on $self.
 313
 314 =head2 get_m2m_source
 315
 316 $self->get_m2m_source( 'name' ) - returns the ResultSource linked to by the many
 317 to many (pseudo) relation 'name' from $self.
 318
 319
 320 =head1 DIAGNOSTICS
 321
 322
 323 =head1 CONFIGURATION AND ENVIRONMENT
 324
 325 DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
 326
 327 =head1 DEPENDENCIES
 328
 329     DBIx::Class
 330
 331 =head1 INCOMPATIBILITIES
 332
 333 =for author to fill in:
 334
 335 None reported.
 336
 337
 338 =head1 BUGS AND LIMITATIONS
 339
 340 =for author to fill in:
 341
 342 No bugs have been reported.
 343
 344 Please report any bugs or feature requests to
 345 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
 346 L<http://rt.cpan.org>.
 347
 348
 349 =head1 AUTHOR
 350
 351 Zbigniew Lukasiak  C<< <zby@cpan.org> >>
 352 Influenced by code by Pedro Melo.
 353
 354 =head1 LICENCE AND COPYRIGHT
 355
 356 Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
 357
 358 This module is free software; you can redistribute it and/or
 359 modify it under the same terms as Perl itself. See L<perlartistic>.
 360
 361
 362 =head1 DISCLAIMER OF WARRANTY
 363
 364 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 365 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 366 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 367 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 368 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 369 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 370 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 371 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 372 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 373
 374 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 375 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 376 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 377 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 378 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 379 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 380 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 381 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 382 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 383 SUCH DAMAGES.