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