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