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