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