X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=d6c5e9bdc58eb8dc78346750faf60fbc13502fde;hb=refs%2Fheads%2Fcurrent%2Fdq;hp=4ff25f7716d0b6991596220044cefb217e5dcc81;hpb=7f7e656eae6ef339f4966c4f02ae033e4ac60c83;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 4ff25f7..d6c5e9b 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -248,7 +248,7 @@ sub new {
     if $source->isa('DBIx::Class::ResultSourceHandle');
 
   $attrs = { %{$attrs||{}} };
-  delete @{$attrs}{qw(_sqlmaker_select_args _related_results_construction)};
+  delete @{$attrs}{qw(_last_sqlmaker_alias_map _related_results_construction)};
 
   if ($attrs->{page}) {
     $attrs->{rows} ||= 10;
@@ -413,6 +413,18 @@ sub search_rs {
     ref $call_cond eq 'ARRAY' && ! @$call_cond
   )) {
     $cache = $self->get_cache;
+  } elsif (
+    $self->{attrs}{cache} and
+    ($self->{attrs}{grep_cache} or $call_attrs->{grep_cache})
+  ) {
+    if (
+      keys %$call_attrs
+      and not (exists $call_attrs->{grep_cache} and !$call_attrs->{grep_cache})
+    ) {
+      die "Can't do complex search on resultset with grep_cache set";
+    }
+    my $grep_one = $self->_construct_perl_predicate($call_cond);
+    $cache = [ grep $grep_one->($_), $self->all ];
   }
 
   my $old_attrs = { %{$self->{attrs}} };
@@ -600,9 +612,94 @@ sub _stack_cond {
 
   return undef unless @top;
 
-  my %top = map +(Data::Dumper::Concise::Dumper($_) => $_), @top;
+  my %seen;
 
-  return \Operator({ 'SQL.Naive' => 'AND' }, [ values %top ]);
+  my @uniq = grep { !$seen{Data::Dumper::Concise::Dumper($_)}++ } @top;
+
+  return \$uniq[0] if @uniq == 1;
+
+  return \Operator({ 'SQL.Naive' => 'AND' }, \@uniq);
+}
+
+my %perl_op_map = (
+  '=' => { numeric => '==', string => 'eq' },
+);
+
+sub _construct_perl_predicate {
+  my ($self, $cond) = @_;
+
+  # This shouldn't really live here but it'll do for the moment.
+
+  my %alias_map = (
+    $self->current_source_alias => {
+      join_path => [],
+      source => $self->result_source,
+      columns_info => $self->result_source->columns_info,
+    },
+  );
+
+  my $attrs = $self->_resolved_attrs;
+  foreach my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) {
+    next unless $j->[0]{-alias};
+    next unless $j->[0]{-join_path};
+    $alias_map{$j->[0]{-alias}} = {
+      join_path => [ map { keys %$_ } @{$j->[0]{-join_path}} ],
+      source => $j->[0]{-rsrc},
+      columns_info => $j->[0]{-rsrc}->columns_info,
+    };
+  }
+
+  my %as_map = map +($attrs->{select}[$_] => $attrs->{as}[$_]),
+                 grep !ref($attrs->{select}[$_]), 0..$#{$attrs->{select}};
+
+  my $storage = $self->result_source->schema->storage;
+  my $sql_maker = $storage->sql_maker;
+  my $tree = map_dq_tree {
+    if (is_Operator) {
+      my $op = $_->{operator}{'SQL.Naive'} or die "No operator";
+      if (lc($op) =~ /^(?:and|or|not)$/i) {
+        return Operator({ 'Perl' => lc($op) }, $op->{args});
+      }
+      if (my $op_map = $perl_op_map{$op}) {
+        die "Binop doesn't have two args - wtf?"
+          unless @{$_->{args}} == 2;
+        my $data_type;
+        my @mapped_args = map {
+          if (is_Identifier) {
+            die "Identifier not alias.colname"
+              unless @{$_->{elements}} == 2;
+            my ($alias, $col) = @{$_->{elements}};
+            die "${alias}.${col} not selected"
+              unless $as_map{"${alias}.${col}"};
+            unless ($data_type) {
+              my $colinfo = $alias_map{$alias}{columns_info}{$col};
+              unless (defined $colinfo->{is_numeric}) {
+                $colinfo->{is_numeric} = (
+                  $storage->is_datatype_numeric($colinfo->{data_type})
+                    ? 1
+                    : 0
+                );
+              }
+              $data_type = $colinfo->{is_numeric} ? 'numeric' : 'string';
+            }
+            Identifier(@{$alias_map{$alias}{join_path}}, $col);
+          } elsif (is_Value) {
+            $_;
+          } else {
+            die "Argument to operator neither identifier nor value";
+          }
+        } @{$_->{args}};
+        die "Couldn't determine numeric versus string" unless $data_type;
+        return \Operator({ Perl => $op_map->{$data_type} }, \@mapped_args);
+      }
+    }
+    die "Unable to map node to perl";
+  } $sql_maker->converter->_where_to_dq($cond);
+  my ($code, @values) = @{$storage->perl_renderer->render($tree)};
+  my $sub = eval q!sub { !.$code.q! }!
+    or die "Failed to build sub: $@";
+  my @args = map $_->{value}, @values;
+  return sub { local $_ = $_[0]; $sub->(@args) };
 }
 
 =head2 search_literal
@@ -1315,7 +1412,7 @@ sub _construct_results {
   return undef unless @{$rows||[]};
 
   # sanity check - people are too clever for their own good
-  if ($attrs->{collapse} and my $aliastypes = $attrs->{_sqlmaker_select_args}[3]{_aliastypes} ) {
+  if ($attrs->{collapse} and my $aliastypes = $attrs->{_last_sqlmaker_alias_map} ) {
 
     my $multiplied_selectors;
     for my $sel_alias ( grep { $_ ne $attrs->{alias} } keys %{ $aliastypes->{selecting} } ) {
@@ -1692,16 +1789,14 @@ sub _count_subq_rs {
         $sql_maker->{name_sep} = '';
       }
 
-      $sql_maker->clear_renderer;
-      $sql_maker->clear_converter;
+      # delete local is 5.12+
+      local @{$sql_maker}{qw(renderer converter)};
+      delete @{$sql_maker}{qw(renderer converter)};
 
       my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep);
 
       my $having_sql = $sql_maker->_render_sqla(where => $attrs->{having});
 
-      $sql_maker->clear_renderer;
-      $sql_maker->clear_converter;
-
       my %seen_having;
 
       # search for both a proper quoted qualified string, for a naive unquoted scalarref
@@ -2475,10 +2570,6 @@ sub _merge_with_rscond {
   if (! defined $self->{cond}) {
     # just massage $data below
   }
-  elsif ($self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
-    %new_data = %{ $self->{attrs}{related_objects} || {} };  # nothing might have been inserted yet
-    @cols_from_relations = keys %new_data;
-  }
   elsif (ref $self->{cond} eq 'HASH') {
     # precedence must be given to passed values over values inherited from
     # the cond, so the order here is important.
@@ -2502,8 +2593,16 @@ sub _merge_with_rscond {
     }
   }
   elsif (ref $self->{cond} eq 'REF' and ref ${$self->{cond}} eq 'HASH') {
-    %new_data = %{$self->result_source
-                       ->_extract_fixed_values_for(${$self->{cond}}, $alias)};
+    if ((${$self->{cond}})->{'DBIx::Class::ResultSource.UNRESOLVABLE'}) {
+      %new_data = %{ $self->{attrs}{related_objects} || {} };  # nothing might have been inserted yet
+      @cols_from_relations = keys %new_data;
+    } else {
+      %new_data = %{$self->_remove_alias(
+        $self->result_source
+             ->_extract_fixed_values_for(${$self->{cond}}),
+        $alias
+      )};
+    }
   }
   else {
     $self->throw_exception(
@@ -2652,8 +2751,6 @@ sub as_query {
     $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs
   );
 
-  $self->{_attrs}{_sqlmaker_select_args} = $attrs->{_sqlmaker_select_args};
-
   $aq;
 }
 
@@ -3522,7 +3619,7 @@ sub _resolved_attrs {
         $source->_resolve_join(
           $join,
           $alias,
-          { %{ $attrs->{seen_join} || {} } },
+          ($attrs->{seen_join} = { %{ $attrs->{seen_join} || {} } }),
           ( $attrs->{seen_join} && keys %{$attrs->{seen_join}})
             ? $attrs->{from}[-1][0]{-join_path}
             : []