X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=5e4b8b5487da4e8bf0f3a4c40420a959d1504c57;hp=0793e0515677e3970cc87beb93cce7fb0c470ecc;hb=1605376709663b035385b41828ce13ae3ed45a4d;hpb=dc81dba3b6a3675dcc003be84fbaad2f0df7d6a2

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 0793e05..5e4b8b5 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -6,7 +6,6 @@ use base qw/DBIx::Class/;
 use Carp::Clan qw/^DBIx::Class/;
 use DBIx::Class::Exception;
 use Data::Page;
-use Storable;
 use DBIx::Class::ResultSetColumn;
 use DBIx::Class::ResultSourceHandle;
 use Hash::Merge ();
@@ -31,7 +30,7 @@ use overload
         'bool'   => "_bool",
         fallback => 1;
 
-__PACKAGE__->mk_group_accessors('simple' => qw/_result_class _source_handle/);
+__PACKAGE__->mk_group_accessors('simple' => qw/_result_class result_source/);
 
 =head1 NAME
 
@@ -197,8 +196,8 @@ sub new {
   return $class->new_result(@_) if ref $class;
 
   my ($source, $attrs) = @_;
-  $source = $source->handle
-    unless $source->isa('DBIx::Class::ResultSourceHandle');
+  $source = $source->resolve
+    if $source->isa('DBIx::Class::ResultSourceHandle');
   $attrs = { %{$attrs||{}} };
 
   if ($attrs->{page}) {
@@ -207,22 +206,18 @@ sub new {
 
   $attrs->{alias} ||= 'me';
 
-  # Creation of {} and bless separated to mitigate RH perl bug
-  # see https://bugzilla.redhat.com/show_bug.cgi?id=196836
-  my $self = {
-    _source_handle => $source,
+  my $self = bless {
+    result_source => $source,
     cond => $attrs->{where},
     pager => undef,
-    attrs => $attrs
-  };
-
-  bless $self, $class;
+    attrs => $attrs,
+  }, $class;
 
   $self->result_class(
-    $attrs->{result_class} || $source->resolve->result_class
+    $attrs->{result_class} || $source->result_class
   );
 
-  return $self;
+  $self;
 }
 
 =head2 search
@@ -702,7 +697,7 @@ sub find {
       next if $keyref eq 'ARRAY'; # has_many for multi_create
 
       my $rel_q = $rsrc->_resolve_condition(
-        $relinfo->{cond}, $val, $key
+        $relinfo->{cond}, $val, $key, $key
       );
       die "Can't handle complex relationship conditions in find" if ref($rel_q) ne 'HASH';
       @related{keys %$rel_q} = values %$rel_q;
@@ -744,7 +739,7 @@ sub find {
       }++;
 
       push @unique_queries, try {
-        $self->_build_unique_cond ($c_name, $call_cond)
+        $self->_build_unique_cond ($c_name, $call_cond, 'croak_on_nulls')
       } || ();
     }
 
@@ -802,8 +797,9 @@ sub _qualify_cond_columns {
   return \%aliased;
 }
 
+my $callsites_warned_ucond;
 sub _build_unique_cond {
-  my ($self, $constraint_name, $extra_cond) = @_;
+  my ($self, $constraint_name, $extra_cond, $croak_on_null) = @_;
 
   my @c_cols = $self->result_source->unique_constraint_columns($constraint_name);
 
@@ -815,15 +811,45 @@ sub _build_unique_cond {
   };
 
   # trim out everything not in $columns
-  $final_cond = { map { $_ => $final_cond->{$_} } @c_cols };
-
-  if (my @missing = grep { ! defined $final_cond->{$_} } (@c_cols) ) {
+  $final_cond = { map {
+    exists $final_cond->{$_}
+      ? ( $_ => $final_cond->{$_} )
+      : ()
+  } @c_cols };
+
+  if (my @missing = grep
+    { ! ($croak_on_null ? defined $final_cond->{$_} : exists $final_cond->{$_}) }
+    (@c_cols)
+  ) {
     $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', no values for column(s): %s",
       $constraint_name,
       join (', ', map { "'$_'" } @missing),
     ) );
   }
 
+  if (
+    !$croak_on_null
+      and
+    !$ENV{DBIC_NULLABLE_KEY_NOWARN}
+      and
+    my @undefs = grep { ! defined $final_cond->{$_} } (keys %$final_cond)
+  ) {
+    my $callsite = do {
+      my $w;
+      local $SIG{__WARN__} = sub { $w = shift };
+      carp;
+      $w
+    };
+
+    carp ( sprintf (
+      "NULL/undef values supplied for requested unique constraint '%s' (NULL "
+    . 'values in column(s): %s). This is almost certainly not what you wanted, '
+    . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.',
+      $constraint_name,
+      join (', ', map { "'$_'" } @undefs),
+    )) unless $callsites_warned_ucond->{$callsite}++;
+  }
+
   return $final_cond;
 }
 
@@ -1948,6 +1974,7 @@ sub populate {
           $reverse_relinfo->{cond},
           $self,
           $result,
+          $rel,
         );
 
         delete $data->[$index]->{$rel};
@@ -1986,6 +2013,7 @@ sub populate {
           $rels->{$rel}{cond},
           $child,
           $main_row,
+          $rel,
         );
 
         my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel});
@@ -2278,7 +2306,6 @@ sub new_result {
     @$cols_from_relations
       ? (-cols_from_relations => $cols_from_relations)
       : (),
-    -source_handle => $self->_source_handle,
     -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED
   );
 
@@ -2318,7 +2345,13 @@ sub _merge_with_rscond {
 
     while ( my($col, $value) = each %implied ) {
       my $vref = ref $value;
-      if ($vref eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '=') {
+      if (
+        $vref eq 'HASH'
+          and
+        keys(%$value) == 1
+          and
+        (keys %$value)[0] eq '='
+      ) {
         $new_data{$col} = $value->{'='};
       }
       elsif( !$vref or $vref eq 'SCALAR' or blessed($value) ) {
@@ -3092,8 +3125,8 @@ sub as_subselect_rs {
   return $fresh_rs->search( {}, {
     from => [{
       $attrs->{alias} => $self->as_query,
-      -alias         => $attrs->{alias},
-      -source_handle => $self->result_source->handle,
+      -alias  => $attrs->{alias},
+      -rsrc   => $self->result_source,
     }],
     alias => $attrs->{alias},
   });
@@ -3143,8 +3176,8 @@ sub _chain_relationship {
     );
 
     $from = [{
-      -source_handle => $source->handle,
-      -alias => $attrs->{alias},
+      -rsrc   => $source,
+      -alias  => $attrs->{alias},
       $attrs->{alias} => $rs_copy->as_query,
     }];
     delete @{$attrs}{@force_subq_attrs, qw/where bind/};
@@ -3155,7 +3188,7 @@ sub _chain_relationship {
   }
   else {
     $from = [{
-      -source_handle => $source->handle,
+      -rsrc  => $source,
       -alias => $attrs->{alias},
       $attrs->{alias} => $source->from,
     }];
@@ -3294,8 +3327,8 @@ sub _resolved_attrs {
   $attrs->{as} = \@as;
 
   $attrs->{from} ||= [{
-    -source_handle => $source->handle,
-    -alias => $self->{attrs}{alias},
+    -rsrc   => $source,
+    -alias  => $self->{attrs}{alias},
     $self->{attrs}{alias} => $source->from,
   }];
 
@@ -3615,17 +3648,6 @@ sub _merge_joinpref_attr {
   }
 }
 
-sub result_source {
-    my $self = shift;
-
-    if (@_) {
-        $self->_source_handle($_[0]->handle);
-    } else {
-        $self->_source_handle->resolve;
-    }
-}
-
-
 sub STORABLE_freeze {
   my ($self, $cloning) = @_;
   my $to_serialize = { %$self };
@@ -3633,7 +3655,7 @@ sub STORABLE_freeze {
   # A cursor in progress can't be serialized (and would make little sense anyway)
   delete $to_serialize->{cursor};
 
-  return nfreeze($to_serialize);
+  nfreeze($to_serialize);
 }
 
 # need this hook for symmetry
@@ -3642,7 +3664,7 @@ sub STORABLE_thaw {
 
   %$self = %{ thaw($serialized) };
 
-  return $self;
+  $self;
 }
 
 
@@ -3655,8 +3677,8 @@ See L<DBIx::Class::Schema/throw_exception> for details.
 sub throw_exception {
   my $self=shift;
 
-  if (ref $self && $self->_source_handle->schema) {
-    $self->_source_handle->schema->throw_exception(@_)
+  if (ref $self and my $rsrc = $self->result_source) {
+    $rsrc->throw_exception(@_)
   }
   else {
     DBIx::Class::Exception->throw(@_);