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