use Carp::Clan instead of warn

[chaz/p5-DBIx-Class-ResultSet-RecursiveUpdate] / lib / DBIx / Class / ResultSet / RecursiveUpdate.pm

diff --git a/lib/DBIx/Class/ResultSet/RecursiveUpdate.pm b/lib/DBIx/Class/ResultSet/RecursiveUpdate.pm
index 68532cec049946cd480633730994e0d0dfee7f9b..4e4c370ea4c972b900660cc90938b1aa9b2e2845 100644 (file)
--- a/lib/DBIx/Class/ResultSet/RecursiveUpdate.pm
+++ b/lib/DBIx/Class/ResultSet/RecursiveUpdate.pm
@@ -3,44 +3,63 @@ use warnings;
 
 package DBIx::Class::ResultSet::RecursiveUpdate;
 
 
 package DBIx::Class::ResultSet::RecursiveUpdate;
 

-our $VERSION = '0.013';
+# ABSTRACT: like update_or_create - but recursive

 
 use base qw(DBIx::Class::ResultSet);
 
 sub recursive_update {
 
 use base qw(DBIx::Class::ResultSet);
 
 sub recursive_update {

-    my ( $self, $updates, $fixed_fields ) = @_;
+    my ( $self, $updates, $attrs ) = @_;
+
+    my $fixed_fields;
+    my $unknown_params_ok;
+
+    # 0.21+ api
+    if ( defined $attrs && ref $attrs eq 'HASH' ) {
+        $fixed_fields      = $attrs->{fixed_fields};
+        $unknown_params_ok = $attrs->{unknown_params_ok};
+    }
+
+    # pre 0.21 api
+    elsif ( defined $attrs && ref $attrs eq 'ARRAY' ) {
+        $fixed_fields = $attrs;
+    }
+

     return
         DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update(
     return
         DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update(

-        resultset    => $self,
-        updates      => $updates,
-        fixed_fields => $fixed_fields
+        resultset         => $self,
+        updates           => $updates,
+        fixed_fields      => $fixed_fields,
+        unknown_params_ok => $unknown_params_ok,

         );
 }
 
 package DBIx::Class::ResultSet::RecursiveUpdate::Functions;
         );
 }
 
 package DBIx::Class::ResultSet::RecursiveUpdate::Functions;

-use Carp;
+use Carp::Clan;

 use Scalar::Util qw( blessed );
 use List::MoreUtils qw/ any /;
 
 sub recursive_update {
     my %params = @_;
     my ( $self, $updates, $fixed_fields, $object, $resolved,
 use Scalar::Util qw( blessed );
 use List::MoreUtils qw/ any /;
 
 sub recursive_update {
     my %params = @_;
     my ( $self, $updates, $fixed_fields, $object, $resolved,

-        $if_not_submitted )
+        $if_not_submitted, $unknown_params_ok )

         = @params{
         = @params{

-        qw/resultset updates fixed_fields object resolved if_not_submitted/};
+        qw/resultset updates fixed_fields object resolved if_not_submitted unknown_params_ok/
+        };

     $resolved ||= {};
 
     # warn 'entering: ' . $self->result_source->from();
     carp 'fixed fields needs to be an array ref'
     $resolved ||= {};
 
     # warn 'entering: ' . $self->result_source->from();
     carp 'fixed fields needs to be an array ref'

-        if $fixed_fields && ref($fixed_fields) ne 'ARRAY';
-    my %fixed_fields;
-    %fixed_fields = map { $_ => 1 } @$fixed_fields if $fixed_fields;
+        if defined $fixed_fields && ref $fixed_fields ne 'ARRAY';
+

     if ( blessed($updates) && $updates->isa('DBIx::Class::Row') ) {
         return $updates;
     }
     if ( $updates->{id} ) {
         $object = $self->find( $updates->{id}, { key => 'primary' } );
     }
     if ( blessed($updates) && $updates->isa('DBIx::Class::Row') ) {
         return $updates;
     }
     if ( $updates->{id} ) {
         $object = $self->find( $updates->{id}, { key => 'primary' } );
     }

+
+    my %fixed_fields = map { $_ => 1 } @$fixed_fields
+        if $fixed_fields;

     my @missing =
         grep { !exists $updates->{$_} && !exists $fixed_fields{$_} }
         $self->result_source->primary_columns;
     my @missing =
         grep { !exists $updates->{$_} && !exists $fixed_fields{$_} }
         $self->result_source->primary_columns;


@@ -123,11 +142,16 @@ sub recursive_update {
         }
 
         # unknown
         }
 
         # unknown

-        # TODO: don't throw a warning instead of an exception to give users
-        #       time to adapt to the new API
-        $self->throw_exception(
+
+        # don't throw a warning instead of an exception to give users
+        # time to adapt to the new API
+        carp(

             "No such column, relationship, many-to-many helper accessor or generic accessor '$name'"
             "No such column, relationship, many-to-many helper accessor or generic accessor '$name'"

-        );
+        ) unless $unknown_params_ok;
+
+#$self->throw_exception(
+#    "No such column, relationship, many-to-many helper accessor or generic accessor '$name'"
+#);

     }
 
     # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;
     }
 
     # warn 'other: ' . Dumper( \%other_methods ); use Data::Dumper;


@@ -155,8 +179,10 @@ sub recursive_update {
     # don't allow insert to recurse to related objects
     # do the recursion ourselves
     # $object->{_rel_in_storage} = 1;
     # don't allow insert to recurse to related objects
     # do the recursion ourselves
     # $object->{_rel_in_storage} = 1;

-    #warn "CHANGED: " . $object->is_changed . " IN STOR: " .  $object->in_storage . "\n";
+    #warn "CHANGED: " . $object->is_changed . "\n":
+    #warn "IN STOR: " .  $object->in_storage . "\n";

     $object->update_or_insert if $object->is_changed;
     $object->update_or_insert if $object->is_changed;

+    $object->discard_changes;

 
     # updating many_to_many
     for my $name ( keys %$updates ) {
 
     # updating many_to_many
     for my $name ( keys %$updates ) {


@@ -251,54 +277,101 @@ sub _update_relation {
             && $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
             == $resolved;
 
             && $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
             == $resolved;
 

-    my $rel_col_cnt = scalar keys %{ $info->{cond} };
-    use Data::Dumper;
-    warn "RELINFO for $name: " . Dumper($info);
-    warn "REL_COL_CNT: $rel_col_cnt";
+    my @rel_cols = keys %{ $info->{cond} };
+    map {s/^foreign\.//} @rel_cols;
+
+    #warn "REL_COLS: " . Dumper(@rel_cols); use Data::Dumper;
+    #my $rel_col_cnt = scalar @rel_cols;
+
+    # find out if all related columns are nullable
+    my $all_fks_nullable = 1;
+    for my $rel_col (@rel_cols) {
+        $all_fks_nullable = 0
+            unless $related_resultset->result_source->column_info($rel_col)
+                ->{is_nullable};
+    }
+
+    $if_not_submitted = $all_fks_nullable ? 'nullify' : 'delete'
+        unless defined $if_not_submitted;

 
 

-    #warn "REV RELINFO for $name: " . Dumper($revrelinfo);
+    #warn "\tNULLABLE: $all_fks_nullable ACTION: $if_not_submitted\n";
+
+    #warn "RELINFO for $name: " . Dumper($info); use Data::Dumper;

 
     # the only valid datatype for a has_many rels is an arrayref
     if ( $info->{attrs}{accessor} eq 'multi' ) {
 
     # the only valid datatype for a has_many rels is an arrayref
     if ( $info->{attrs}{accessor} eq 'multi' ) {

+
+        # handle undef like empty arrayref
+        $updates = []
+            unless defined $updates;

         $self->throw_exception(
             "data for has_many relationship '$name' must be an arrayref")
             unless ref $updates eq 'ARRAY';
 
         $self->throw_exception(
             "data for has_many relationship '$name' must be an arrayref")
             unless ref $updates eq 'ARRAY';
 

-        my @updated_ids;
+        my @updated_objs;
+
+        #warn "\tupdating has_many rel '$name' ($rel_col_cnt columns cols)\n";

         for my $sub_updates ( @{$updates} ) {
             my $sub_object = recursive_update(
                 resultset => $related_resultset,
                 updates   => $sub_updates,
                 resolved  => $resolved
             );
         for my $sub_updates ( @{$updates} ) {
             my $sub_object = recursive_update(
                 resultset => $related_resultset,
                 updates   => $sub_updates,
                 resolved  => $resolved
             );

-            push @updated_ids, $sub_object->id;
+
+            push @updated_objs, $sub_object;

         }
         }

+
+        #warn "\tcreated and updated related rows\n";
+

         my @related_pks = $related_resultset->result_source->primary_columns;
         my @related_pks = $related_resultset->result_source->primary_columns;

-        if ( defined $if_not_submitted && $if_not_submitted eq 'delete' ) {

 
 

-            # only handles related result classes with single primary keys
-            if ( 1 == scalar @related_pks ) {
-                $object->$name->search(
-                    { $related_pks[0] => { -not_in => \@updated_ids } } )
-                    ->delete;
-            }
+        my $rs_rel_delist = $object->$name;
+
+        # foreign table has a single pk column
+        if ( scalar @related_pks == 1 ) {
+            $rs_rel_delist = $rs_rel_delist->search_rs(
+                {   $related_pks[0] =>
+                        { -not_in => [ map ( $_->id, @updated_objs ) ] }
+                }
+            );

         }
         }

-        elsif ( defined $if_not_submitted
-            && $if_not_submitted eq 'set_to_null' )
-        {

 
 

-            # only handles related result classes with single primary keys
-            if ( 1 == scalar @related_pks ) {
-                my @fk = keys %$resolved;
-                $object->$name->search(
-                    { $related_pks[0] => { -not_in => \@updated_ids } } )
-                    ->update( { $fk[0] => undef } );
+        # foreign table has multiple pk columns
+        else {
+            my @cond;
+            for my $obj (@updated_objs) {
+                my %cond_for_obj;
+                for my $col (@related_pks) {
+                    $cond_for_obj{$col} = $obj->get_column($col);
+                }
+                push @cond, \%cond_for_obj;
+            }
+
+            # only limit resultset if there are related rows left
+            if ( scalar @cond ) {
+                $rs_rel_delist =
+                    $rs_rel_delist->search_rs( { -not => [@cond] } );

             }
         }
             }
         }

+
+        #warn "\tCOND: " . Dumper(\%cond);
+        #my $rel_delist_cnt = $rs_rel_delist->count;
+        if ( $if_not_submitted eq 'delete' ) {
+
+            #warn "\tdeleting related rows: $rel_delist_cnt\n";
+            $rs_rel_delist->delete;
+        }
+        elsif ( $if_not_submitted eq 'set_to_null' ) {
+
+            #warn "\tnullifying related rows: $rel_delist_cnt\n";
+            my %update = map { $_ => undef } @rel_cols;
+            $rs_rel_delist->update( \%update );
+        }

     }
     elsif ($info->{attrs}{accessor} eq 'single'
         || $info->{attrs}{accessor} eq 'filter' )
     {
     }
     elsif ($info->{attrs}{accessor} eq 'single'
         || $info->{attrs}{accessor} eq 'filter' )
     {

+

         #warn "\tupdating rel '$name': $if_not_submitted\n";
         my $sub_object;
         if ( ref $updates ) {
         #warn "\tupdating rel '$name': $if_not_submitted\n";
         my $sub_object;
         if ( ref $updates ) {


@@ -466,61 +539,61 @@ sub _master_relation_cond {
 1;    # Magic true value required at end of module
 __END__
 
 1;    # Magic true value required at end of module
 __END__
 

-=head1 NAME
-
-DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive
-

 =head1 SYNOPSIS
 
 =head1 SYNOPSIS
 

-The functional interface:
+    # The functional interface:

 
 

-    my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update({ 
-        resultset => $schema->resultset( 'Dvd' ),
+    my $schema = MyDB::Schema->connect();
+    my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update(
+        resultset => $schema->resultset('User'),

         updates => {
         updates => {

-            id => 1, 
-            owned_dvds => [ 
-                { 
-                  title => 'One Flew Over the Cuckoo's Nest' 
-                } 
-            ] 
-        }
-    });
+            id => 1,
+            owned_dvds => [
+                {
+                    title => "One Flew Over the Cuckoo's Nest"
+                }
+            ]
+        },
+        unknown_params_ok => 1,
+    );

 
 
 
 

-As ResultSet subclass:
+    # As ResultSet subclass:

 
     __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
 
 
     __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
 

-in the Schema file (see t/lib/DBSchema.pm).  Or appriopriate 'use base' in the ResultSet classes. 
+    # in the Schema file (see t/lib/DBSchema.pm).  Or appropriate 'use base' in the ResultSet classes.

 
 

-Then:
+    my $user = $schema->resultset('User')->recursive_update({
+        id => 1,
+        owned_dvds => [
+            {
+                title => "One Flew Over the Cuckoo's Nest"
+            }
+        ]
+    }, {
+        unknown_params_ok => 1,
+    });

 
 

-    my $user = $user_rs->recursive_update( { 
-        id => 1, 
-        owned_dvds => [ 
-        { 
-          title => 'One Flew Over the Cuckoo's Nest' 
-        } 
-        ] 
-      }
-    );

 
 

-  

 =head1 DESCRIPTION
 
 =head1 DESCRIPTION
 

-This is still experimental. I've added a functional interface so that it can be used 
-in Form Processors and not require modification of the model.
+This is still experimental.

 
 

-You can feed the ->create method with a recursive datastructure and have the related records
-created.  Unfortunately you cannot do a similar thing with update_or_create - this module
-tries to fill that void. 
+You can feed the ->create method of DBIx::Class with a recursive datastructure
+and have the related records created. Unfortunately you cannot do a similar
+thing with update_or_create.
+This module tries to fill that void until L<DBIx::Class> has an api itself.

 
 

-It is a base class for ResultSets providing just one method: recursive_update
+The functional interface can be used without modifications of the model,
+for example by form processors like L<HTML::FormHandler::Model::DBIC>.
+
+It is a base class for L<DBIx::Class::ResultSet>s providing the method recursive_update

 which works just like update_or_create but can recursively update or create
 data objects composed of multiple rows. All rows need to be identified by primary keys
 - so you need to provide them in the update structure (unless they can be deduced from 
 the parent row - for example when you have a belongs_to relationship).  
 which works just like update_or_create but can recursively update or create
 data objects composed of multiple rows. All rows need to be identified by primary keys
 - so you need to provide them in the update structure (unless they can be deduced from 
 the parent row - for example when you have a belongs_to relationship).  

-If not all colums comprising the primary key are specified - then a new row will be created,
+If not all columns comprising the primary key are specified a new row will be created,

 with the expectation that the missing columns will be filled by it (as in the case of auto_increment 
 primary keys).  
 
 with the expectation that the missing columns will be filled by it (as in the case of auto_increment 
 primary keys).  
 


@@ -530,28 +603,27 @@ like in the case of:
     
     my $restricted_rs = $user_rs->search( { id => 1 } );
 
     
     my $restricted_rs = $user_rs->search( { id => 1 } );
 

-then you need to inform recursive_update about additional predicate with a second argument:
+then you need to inform recursive_update about the additional predicate with the fixed_fields attribute:

 
 

-    my $user = $restricted_rs->recursive_update( { 
-        owned_dvds => [ 
-        { 
-          title => 'One Flew Over the Cuckoo's Nest' 
-        } 
-        ] 
-      },
-      [ 'id' ]
+    my $user = $restricted_rs->recursive_update( {
+            owned_dvds => [
+            {
+                title => 'One Flew Over the Cuckoo's Nest'
+            }
+            ]
+        },
+        {
+            fixed_fields => [ 'id' ],
+        }

     );
 
     );
 

-This will work with a new DBIC release.
-

 For a many_to_many (pseudo) relation you can supply a list of primary keys
 For a many_to_many (pseudo) relation you can supply a list of primary keys

-from the other table - and it will link the record at hand to those and
+from the other table and it will link the record at hand to those and

 only those records identified by them.  This is convenient for handling web
 only those records identified by them.  This is convenient for handling web

-forms with check boxes (or a SELECT box with multiple choice) that let you
+forms with check boxes (or a select field with multiple choice) that lets you

 update such (pseudo) relations.  
 
 update such (pseudo) relations.  
 

-For a description how to set up base classes for ResultSets see load_namespaces
-in DBIx::Class::Schema.
+For a description how to set up base classes for ResultSets see L<DBIx::Class::Schema/load_namespaces>.

 
 =head1 DESIGN CHOICES
 
 
 =head1 DESIGN CHOICES
 


@@ -674,7 +746,7 @@ Clearing the relationship:
 
 =head2 Treatment of many-to-many pseudo relations
 
 
 =head2 Treatment of many-to-many pseudo relations
 

-The function gets the information about m2m relations from DBIx::Class::IntrospectableM2M.
+The function gets the information about m2m relations from L<DBIx::Class::IntrospectableM2M>.

 If it isn't loaded in the ResultSource classes the code relies on the fact that:
 
     if($object->can($name) and
 If it isn't loaded in the ResultSource classes the code relies on the fact that:
 
     if($object->can($name) and


@@ -729,40 +801,3 @@ No bugs have been reported.
 Please report any bugs or feature requests to
 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
 L<http://rt.cpan.org>.
 Please report any bugs or feature requests to
 C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
 L<http://rt.cpan.org>.

-
-
-=head1 AUTHOR
-
-Zbigniew Lukasiak  C<< <zby@cpan.org> >>
-Influenced by code by Pedro Melo.
-
-=head1 LICENCE AND COPYRIGHT
-
-Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
-
-This module is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself. See L<perlartistic>.
-
-
-=head1 DISCLAIMER OF WARRANTY
-
-BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
-FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
-PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
-EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
-ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
-YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
-NECESSARY SERVICING, REPAIR, OR CORRECTION.
-
-IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
-REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
-LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
-OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
-THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
-RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
-FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
-SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
-SUCH DAMAGES.