first cut of grep_cache feature

diff --git a/lib/DBIx/Class/PerlRenderer.pm b/lib/DBIx/Class/PerlRenderer.pm
new file mode 100644 (file)
index 0000000..051a3c5
--- /dev/null
+++ b/lib/DBIx/Class/PerlRenderer.pm
@@ -0,0 +1,15 @@
+package DBIx::Class::PerlRenderer;
+
+use B qw(perlstring);
+use Moo;
+
+extends 'Data::Query::Renderer::Perl';
+
+around _render_identifier => sub {
+  my ($orig, $self) = (shift, shift);
+  my $dq = +{ %{$_[0]}, elements => [ @{$_[0]->{elements}} ] };
+  my $last = pop @{$dq->{elements}};
+  [ $self->$orig($dq)->[0].'->get_column('.perlstring($last).')' ];
+};
+
+1;

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 6019d7c..77d04b2 100644 (file)
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -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}} };
@@ -609,6 +621,87 @@ sub _stack_cond {
   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
 
 B<CAVEAT>: C<search_literal> is provided for Class::DBI compatibility and

diff --git a/lib/DBIx/Class/ResultSet/Role/DQMethods.pm b/lib/DBIx/Class/ResultSet/Role/DQMethods.pm
index 83882e3..b7745a9 100644 (file)
--- a/lib/DBIx/Class/ResultSet/Role/DQMethods.pm
+++ b/lib/DBIx/Class/ResultSet/Role/DQMethods.pm
@@ -24,7 +24,7 @@ sub where {
 sub _apply_dq_where {
   my ($self, $expr) = @_;
   my ($mapped, $need_join) = $self->_remap_identifiers($expr);
-  $self->search_rs(\$mapped, { join => $need_join });
+  $self->search_rs(\$mapped, (@$need_join ? { join => $need_join } : ()));
 }
 
 sub _remap_identifiers {

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 9678c28..fe833b8 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -145,6 +145,14 @@ for my $meth (@rdbms_specific_methods) {
   };
 }
 
+sub perl_renderer {
+  my ($self) = @_;
+  $self->{perl_renderer} ||= do {
+    require DBIx::Class::PerlRenderer;
+    DBIx::Class::PerlRenderer->new;
+  };
+}
+
 =head1 NAME
 
 DBIx::Class::Storage::DBI - DBI storage handler

diff --git a/t/dq/grep_cache.t b/t/dq/grep_cache.t
new file mode 100644 (file)
index 0000000..5dd7243
--- /dev/null
+++ b/t/dq/grep_cache.t
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use Test::Warn;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+use Data::Query::ExprDeclare;
+
+my $schema = DBICTest->init_schema();
+
+my $cds = $schema->resultset('CD');
+
+my $restricted = $cds->search({}, { cache => 1, grep_cache => 1 })
+                     ->search({ 'me.artist' => 1 });
+
+is($restricted->count, 3, 'Count on restricted ok');
+
+$restricted = $cds->search(
+                      {},
+                      { prefetch => 'artist', cache => 1, grep_cache => 1 }
+                    )
+                  ->search({ 'artist.name' => 'Caterwauler McCrae' });
+
+is($restricted->count, 3, 'Count on restricted ok via join');
+
+done_testing;