From: Matt S Trout Date: Sun, 24 Nov 2013 09:25:09 +0000 (+0000) Subject: first cut of grep_cache feature X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c1b3830047a2a19fcba3e2b81eea44b9cd62238f;p=dbsrgits%2FDBIx-Class.git first cut of grep_cache feature --- diff --git a/lib/DBIx/Class/PerlRenderer.pm b/lib/DBIx/Class/PerlRenderer.pm new file mode 100644 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 --- 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: C 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 --- 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 --- 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 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;