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