X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=8e44f82ef4c29f8e42684333e1085cca799233c2;hb=8dc9c09f877e9719bef9470a5d376f0d5351786f;hp=c2bde273f12a341d76e9152699f06a8ff4d7cc79;hpb=bee6d1919f199cba962576e1fce3fca80f677d3e;p=dbsrgits%2FDBIx-Class-Historic.git

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index c2bde27..8e44f82 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -299,77 +299,72 @@ sub find {
   ) unless @cols;
 
   # Parse out a hashref from input
-  my $cond;
+  my $input_query;
   if (ref $_[0] eq 'HASH') {
-    $cond = { %{$_[0]} };
+    $input_query = { %{$_[0]} };
   }
   elsif (@_ == @cols) {
-    $cond = {};
-    @{$cond}{@cols} = @_;
+    $input_query = {};
+    @{$input_query}{@cols} = @_;
   }
   else {
     # Compatibility: Allow e.g. find(id => $value)
-    carp "find by key => value deprecated; please use a hashref instead";
-    $cond = {@_};
+    carp "Find by key => value deprecated; please use a hashref instead";
+    $input_query = {@_};
   }
 
-  return $self->_find($cond, $attrs);
+  my @unique_queries = $self->_unique_queries($input_query, $attrs);
+#  use Data::Dumper; warn Dumper $self->result_source->name, $input_query, \@unique_queries, $self->{attrs}->{where};
+
+  # Verify the query
+  my $query = \@unique_queries;
+  if (scalar @unique_queries == 0) {
+    # Handle cases where the ResultSet defines the query, or where the user is
+    # abusing find
+    $query = $input_query;
+  }
+
+  # Run the query
+  if (keys %$attrs) {
+    my $rs = $self->search($query, $attrs);
+    $rs->_resolve;
+    return keys %{$rs->{_attrs}->{collapse}} ? $rs->next : $rs->single;
+  }
+  else {
+    $self->_resolve;  
+    return (keys %{$self->{_attrs}->{collapse}})
+      ? $self->search($query)->next
+      : $self->single($query);
+  }
 }
 
-# _find
+# _unique_queries
 #
-# Helper method: search against the unique constraints.
+# Build a list of queries which satisfy unique constraints.
 
-sub _find {
-  my ($self, $cond, $attrs) = @_;
+sub _unique_queries {
+  my ($self, $query, $attrs) = @_;
 
-  # Check the condition against our source's unique constraints
   my @constraint_names = exists $attrs->{key}
     ? ($attrs->{key})
     : $self->result_source->unique_constraint_names;
 
-  my @unique_conds;
+  my @unique_queries;
   foreach my $name (@constraint_names) {
     my @unique_cols = $self->result_source->unique_constraint_columns($name);
-    my $unique_cond = $self->_build_unique_query($cond, \@unique_cols);
+    my $unique_query = $self->_build_unique_query($query, \@unique_cols);
 
-    next unless scalar keys %$unique_cond == scalar @unique_cols;
+    next unless scalar keys %$unique_query;
 
     # Add the ResultSet's alias
-    foreach my $key (grep { ! m/\./ } keys %$unique_cond) {
-      $unique_cond->{"$self->{attrs}{alias}.$key"} = delete $unique_cond->{$key};
+    foreach my $key (grep { ! m/\./ } keys %$unique_query) {
+      $unique_query->{"$self->{attrs}->{alias}.$key"} = delete $unique_query->{$key};
     }
 
-    push @unique_conds, $unique_cond;
+    push @unique_queries, $unique_query;
   }
-#  use Data::Dumper; warn Dumper $self->result_source->name, $cond, \@unique_conds;
 
-  # Verify the query
-  my $query = \@unique_conds;
-  if (scalar @unique_conds == 0) {
-    if (exists $attrs->{key}) {
-      $self->throw_exception("required values for the $attrs->{key} key not provided");
-    }
-    else {
-      # Compatibility: Allow broken find usage for now
-      carp "find requires values for the primary key or a unique constraint"
-        . "; please use search instead";
-      $query = $cond;
-    }
-  }
-
-  # Run the query
-  if (keys %$attrs) {
-    my $rs = $self->search($query, $attrs);
-    $rs->_resolve;
-    return keys %{$rs->{_attrs}->{collapse}} ? $rs->next : $rs->single;
-  }
-  else {
-    $self->_resolve;  
-    return (keys %{$self->{_attrs}->{collapse}})
-      ? $self->search($query)->next
-      : $self->single($query);
-  }
+  return @unique_queries;
 }
 
 # _build_unique_query
@@ -472,12 +467,87 @@ sub single {
     }
   }
 
+#  use Data::Dumper; warn Dumper $attrs->{where};
+  unless ($self->_is_unique_query($attrs->{where})) {
+    carp "Query not guarnteed to return a single row"
+      . "; please declare your unique constraints or use search instead";
+  }
+
   my @data = $self->result_source->storage->select_single(
           $attrs->{from}, $attrs->{select},
           $attrs->{where},$attrs);
   return (@data ? $self->_construct_object(@data) : ());
 }
 
+# _is_unique_query
+#
+# Try to determine if the specified query is guaranteed to be unique, based on
+# the declared unique constraints.
+
+sub _is_unique_query {
+  my ($self, $query) = @_;
+
+  my $collapsed = $self->_collapse_query($query);
+#  use Data::Dumper; warn Dumper $collapsed;
+
+  foreach my $name ($self->result_source->unique_constraint_names) {
+    my @unique_cols = map { "$self->{attrs}->{alias}.$_" }
+      $self->result_source->unique_constraint_columns($name);
+
+    # Count the values for each unique column
+    my %seen = map { $_ => 0 } @unique_cols;
+
+    foreach my $key (keys %$collapsed) {
+      my $aliased = $key;
+      $aliased = "$self->{attrs}->{alias}.$key" unless $key =~ /\./;
+
+      next unless exists $seen{$aliased};  # Additional constraints are okay
+      $seen{$aliased} = scalar @{ $collapsed->{$key} };
+    }
+
+    # If we get 0 or more than 1 value for a column, it's not necessarily unique
+    return 1 unless grep { $_ != 1 } values %seen;
+  }
+
+  return 0;
+}
+
+# _collapse_query
+#
+# Recursively collapse the query, accumulating values for each column.
+
+sub _collapse_query {
+  my ($self, $query, $collapsed) = @_;
+
+  # Accumulate fields in the AST
+  $collapsed ||= {};
+
+  if (ref $query eq 'ARRAY') {
+    foreach my $subquery (@$query) {
+      next unless ref $subquery;  # -or
+#      warn "ARRAY: " . Dumper $subquery;
+      $collapsed = $self->_collapse_query($subquery, $collapsed);
+    }
+  }
+  elsif (ref $query eq 'HASH') {
+    if (keys %$query and (keys %$query)[0] eq '-and') {
+      foreach my $subquery (@{$query->{-and}}) {
+#        warn "HASH: " . Dumper $subquery;
+        $collapsed = $self->_collapse_query($subquery, $collapsed);
+      }
+    }
+    else {
+#      warn "LEAF: " . Dumper $query;
+      foreach my $key (keys %$query) {
+        push @{$collapsed->{$key}}, $query->{$key};
+      }
+#      warn Dumper $collapsed;
+    }
+  }
+
+  return $collapsed;
+}
+
 =head2 get_column
 
 =over 4