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