X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FRow.pm;h=5c4cead70fd5d74b9184d44467f77b9d12040e93;hb=22030f6f3e5ace15060ba1233682dfcfdfb318a7;hp=2aa5b2395148e499acb91e94c4d38eca5c64eb9f;hpb=a5f5e47019daf25c0b0f9708cbd3ab2695584c5a;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm
index 2aa5b23..5c4cead 100644
--- a/lib/DBIx/Class/Row.pm
+++ b/lib/DBIx/Class/Row.pm
@@ -6,10 +6,9 @@ use warnings;
 use base qw/DBIx::Class/;
 
 use Scalar::Util 'blessed';
-use List::Util 'first';
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
 use DBIx::Class::Carp;
-use DBIx::Class::_Util 'is_literal_value';
+use SQL::Abstract qw( is_literal_value is_plain_value );
 
 ###
 ### Internal method
@@ -52,7 +51,7 @@ All "Row objects" derived from a Schema-attached L<DBIx::Class::ResultSet>
 object (such as a typical C<< L<search|DBIx::Class::ResultSet/search>->
 L<next|DBIx::Class::ResultSet/next> >> call) are actually Result
 instances, based on your application's
-L<Result class|DBIx::Class::Manual::Glossary/Result_class>.
+L<Result Class|DBIx::Class::Manual::Glossary/Result Class>.
 
 L<DBIx::Class::Row> implements most of the row-based communication with the
 underlying storage, but a Result class B<should not inherit from it directly>.
@@ -257,14 +256,16 @@ sub new {
           }
           $inflated->{$key} = $rel_obj;
           next;
-        } elsif ($class->has_column($key)
-            && $class->column_info($key)->{_inflate_info}) {
+        }
+        elsif (
+          $rsrc->has_column($key)
+            and
+          $rsrc->column_info($key)->{_inflate_info}
+        ) {
           $inflated->{$key} = $attrs->{$key};
           next;
         }
       }
-      $new->throw_exception("No such column '$key' on $class")
-        unless $class->has_column($key);
       $new->store_column($key => $attrs->{$key});
     }
 
@@ -371,8 +372,7 @@ sub insert {
       my $existing;
 
       # if there are no keys - nothing to search for
-      if (keys %$them and $existing = $self->result_source
-                                           ->related_source($rel_name)
+      if (keys %$them and $existing = $rsrc->related_source($rel_name)
                                            ->resultset
                                            ->find($them)
       ) {
@@ -478,8 +478,8 @@ sub insert {
 
 Indicates whether the object exists as a row in the database or
 not. This is set to true when L<DBIx::Class::ResultSet/find>,
-L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
-are used.
+L<DBIx::Class::ResultSet/create> or L<DBIx::Class::Row/insert>
+are invoked.
 
 Creating a result object using L<DBIx::Class::ResultSet/new_result>, or
 calling L</delete> on one, sets it to false.
@@ -619,7 +619,7 @@ sub delete {
     $self->in_storage(0);
   }
   else {
-    my $rsrc = try { $self->result_source_instance }
+    my $rsrc = dbic_internal_try { $self->result_source_instance }
       or $self->throw_exception("Can't do class delete without a ResultSource instance");
 
     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
@@ -673,8 +673,8 @@ sub get_column {
     ));
   }
 
-  $self->throw_exception( "No such column '${column}'" )
-    unless $self->has_column($column);
+  $self->throw_exception( "No such column '${column}' on " . ref $self )
+    unless $self->result_source->has_column($column);
 
   return undef;
 }
@@ -801,8 +801,8 @@ really changed.
 sub make_column_dirty {
   my ($self, $column) = @_;
 
-  $self->throw_exception( "No such column '${column}'" )
-    unless exists $self->{_column_data}{$column} || $self->has_column($column);
+  $self->throw_exception( "No such column '${column}' on " . ref $self )
+    unless exists $self->{_column_data}{$column} || $self->result_source->has_column($column);
 
   # the entire clean/dirty code relies on exists, not on true/false
   return 1 if exists $self->{_dirty_columns}{$column};
@@ -844,9 +844,9 @@ See L<DBIx::Class::InflateColumn> for how to setup inflation.
 sub get_inflated_columns {
   my $self = shift;
 
-  my $loaded_colinfo = $self->columns_info ([
-    grep { $self->has_column_loaded($_) } $self->columns
-  ]);
+  my $loaded_colinfo = $self->result_source->columns_info;
+  $self->has_column_loaded($_) or delete $loaded_colinfo->{$_}
+    for keys %$loaded_colinfo;
 
   my %cols_to_return = ( %{$self->{_column_data}}, %$loaded_colinfo );
 
@@ -888,14 +888,20 @@ sub get_inflated_columns {
 }
 
 sub _is_column_numeric {
-   my ($self, $column) = @_;
-    my $colinfo = $self->column_info ($column);
+    my ($self, $column) = @_;
+
+    my $rsrc;
+
+    return undef
+      unless ( $rsrc = $self->result_source )->has_column($column);
+
+    my $colinfo = $rsrc->column_info ($column);
 
     # cache for speed (the object may *not* have a resultsource instance)
     if (
       ! defined $colinfo->{is_numeric}
         and
-      my $storage = try { $self->result_source->schema->storage }
+      my $storage = dbic_internal_try { $rsrc->schema->storage }
     ) {
       $colinfo->{is_numeric} =
         $storage->is_datatype_numeric ($colinfo->{data_type})
@@ -940,9 +946,10 @@ sub set_column {
   my $dirty =
     $self->{_dirty_columns}{$column}
       ||
-    $self->in_storage # no point tracking dirtyness on uninserted data
+    ( $self->in_storage # no point tracking dirtyness on uninserted data
       ? ! $self->_eq_column_values ($column, $old_value, $new_value)
       : 1
+    )
   ;
 
   if ($dirty) {
@@ -1020,7 +1027,10 @@ sub _eq_column_values {
 # value tracked between column changes and commitment to storage
 sub _track_storage_value {
   my ($self, $col) = @_;
-  return defined first { $col eq $_ } ($self->primary_columns);
+  return scalar grep
+    { $col eq $_ }
+    $self->result_source->primary_columns
+  ;
 }
 
 =head2 set_columns
@@ -1082,9 +1092,11 @@ See also L<DBIx::Class::Relationship::Base/set_from_related>.
 
 sub set_inflated_columns {
   my ( $self, $upd ) = @_;
+  my $rsrc;
   foreach my $key (keys %$upd) {
     if (ref $upd->{$key}) {
-      my $info = $self->relationship_info($key);
+      $rsrc ||= $self->result_source;
+      my $info = $rsrc->relationship_info($key);
       my $acc_type = $info->{attrs}{accessor} || '';
 
       if ($acc_type eq 'single') {
@@ -1097,7 +1109,11 @@ sub set_inflated_columns {
           "Recursive update is not supported over relationships of type '$acc_type' ($key)"
         );
       }
-      elsif ($self->has_column($key) && exists $self->column_info($key)->{_inflate_info}) {
+      elsif (
+        $rsrc->has_column($key)
+          and
+        exists $rsrc->column_info($key)->{_inflate_info}
+      ) {
         $self->set_inflated_column($key, delete $upd->{$key});
       }
     }
@@ -1135,18 +1151,20 @@ is set by default on C<has_many> relationships and unset on all others.
 sub copy {
   my ($self, $changes) = @_;
   $changes ||= {};
-  my $col_data = { %{$self->{_column_data}} };
+  my $col_data = { $self->get_columns };
+
+  my $rsrc = $self->result_source;
 
-  my $colinfo = $self->columns_info([ keys %$col_data ]);
+  my $colinfo = $rsrc->columns_info;
   foreach my $col (keys %$col_data) {
     delete $col_data->{$col}
-      if $colinfo->{$col}{is_auto_increment};
+      if ( ! $colinfo->{$col} or $colinfo->{$col}{is_auto_increment} );
   }
 
   my $new = { _column_data => $col_data };
   bless $new, ref $self;
 
-  $new->result_source($self->result_source);
+  $new->result_source($rsrc);
   $new->set_inflated_columns($changes);
   $new->insert;
 
@@ -1155,23 +1173,26 @@ sub copy {
   # constraints
   my $rel_names_copied = {};
 
-  foreach my $rel_name ($self->result_source->relationships) {
-    my $rel_info = $self->result_source->relationship_info($rel_name);
+  foreach my $rel_name ($rsrc->relationships) {
+    my $rel_info = $rsrc->relationship_info($rel_name);
 
     next unless $rel_info->{attrs}{cascade_copy};
 
-    my $resolved = $self->result_source->_resolve_condition(
-      $rel_info->{cond}, $rel_name, $new, $rel_name
-    );
-
+    my $foreign_vals;
     my $copied = $rel_names_copied->{ $rel_info->{source} } ||= {};
-    foreach my $related ($self->search_related($rel_name)->all) {
-      my $id_str = join("\0", $related->id);
-      next if $copied->{$id_str};
-      $copied->{$id_str} = 1;
-      my $rel_copy = $related->copy($resolved);
-    }
 
+    $copied->{$_->ID}++ or $_->copy(
+
+      $foreign_vals ||= $rsrc->_resolve_relationship_condition(
+        infer_values_based_on => {},
+        rel_name => $rel_name,
+        self_result_object => $new,
+
+        self_alias => "\xFE", # irrelevant
+        foreign_alias => "\xFF", # irrelevant,
+      )->{inferred_values}
+
+    ) for $self->search_related($rel_name)->all;
   }
   return $new;
 }
@@ -1199,11 +1220,22 @@ extend this method to catch all data setting methods.
 
 sub store_column {
   my ($self, $column, $value) = @_;
-  $self->throw_exception( "No such column '${column}'" )
-    unless exists $self->{_column_data}{$column} || $self->has_column($column);
+  $self->throw_exception( "No such column '${column}' on " . ref $self )
+    unless exists $self->{_column_data}{$column} || $self->result_source->has_column($column);
   $self->throw_exception( "set_column called for ${column} without value" )
     if @_ < 3;
-  return $self->{_column_data}{$column} = $value;
+
+  return $self->{_column_data}{$column} = $value
+    unless length ref $value and my $vref = is_plain_value( $value );
+
+  # if we are dealing with a value/ref - there are a couple possibilities
+  # unpack the underlying piece of data and stringify all objects explicitly
+  # ( to accomodate { -value => ... } and guard against overloaded objects
+  # with defined stringification AND fallback => 0 (ugh!)
+  $self->{_column_data}{$column} = defined blessed $$vref
+    ? "$$vref"
+    : $$vref
+  ;
 }
 
 =head2 inflate_result
@@ -1313,7 +1345,7 @@ sub inflate_result {
 
 =back
 
-L</Update>s the object if it's already in the database, according to
+L</update>s the object if it's already in the database, according to
 L</in_storage>, else L</insert>s it.
 
 =head2 insert_or_update
@@ -1400,11 +1432,10 @@ sub result_source {
 
     # note this is a || not a ||=, the difference is important
     : $_[0]->{_result_source} || do {
-        my $class = ref $_[0];
         $_[0]->can('result_source_instance')
           ? $_[0]->result_source_instance
           : $_[0]->throw_exception(
-            "No result source instance registered for $class, did you forget to call $class->table(...) ?"
+            "No result source instance registered for @{[ ref $_[0] ]}, did you forget to call @{[ ref $_[0] ]}->table(...) ?"
           )
       }
   ;
@@ -1553,8 +1584,12 @@ See L<DBIx::Class::Schema/throw_exception>.
 sub throw_exception {
   my $self=shift;
 
-  if (ref $self && ref $self->result_source ) {
-    $self->result_source->throw_exception(@_)
+  if (
+    ! DBIx::Class::_Util::in_internal_try
+      and
+    my $rsrc = dbic_internal_try { $self->result_source }
+  ) {
+    $rsrc->throw_exception(@_)
   }
   else {
     DBIx::Class::Exception->throw(@_);
@@ -1576,13 +1611,16 @@ sub throw_exception {
 Returns the primary key(s) for a row. Can't be called as a class method.
 Actually implemented in L<DBIx::Class::PK>
 
-=head1 AUTHOR AND CONTRIBUTORS
+=head1 FURTHER QUESTIONS?
 
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
 
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
 
 =cut