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