use Scalar::Util qw/blessed weaken reftype/;
use DBIx::Class::_Util 'fail_on_internal_wantarray';
use Try::Tiny;
-use Data::Compare (); # no imports!!! guard against insane architecture
+use Data::Dumper::Concise ();
use Data::Query::Constants;
use Data::Query::ExprHelpers;
# not importing first() as it will clash with our own method
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;
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}} };
sub _stack_cond {
my ($self, $left, $right) = @_;
- # collapse single element top-level conditions
- # (single pass only, unlikely to need recursion)
- for ($left, $right) {
- if (ref $_ eq 'ARRAY') {
- if (@$_ == 0) {
- $_ = undef;
- }
- elsif (@$_ == 1) {
- $_ = $_->[0];
- }
- }
- elsif (ref $_ eq 'HASH') {
- my ($first, $more) = keys %$_;
+ my $source = $self->result_source;
- # empty hash
- if (! defined $first) {
- $_ = undef;
- }
- # one element hash
- elsif (! defined $more) {
- if ($first eq '-and' and ref $_->{'-and'} eq 'HASH') {
- $_ = $_->{'-and'};
- }
- elsif ($first eq '-or' and ref $_->{'-or'} eq 'ARRAY') {
- $_ = $_->{'-or'};
- }
- }
- }
- }
+ my $converter = $source->schema->storage->sql_maker->converter;
- # merge hashes with weeding out of duplicates (simple cases only)
- if (ref $left eq 'HASH' and ref $right eq 'HASH') {
+ my @top = map $source->_extract_top_level_conditions(
+ $converter->_expr_to_dq($_)
+ ), grep defined, $left, $right;
- # shallow copy to destroy
- $right = { %$right };
- for (grep { exists $right->{$_} } keys %$left) {
- # the use of eq_deeply here is justified - the rhs of an
- # expression can contain a lot of twisted weird stuff
- delete $right->{$_} if Data::Compare::Compare( $left->{$_}, $right->{$_} );
- }
+ return undef unless @top;
- $right = undef unless keys %$right;
- }
+ my %seen;
+ my @uniq = grep { !$seen{Data::Dumper::Concise::Dumper($_)}++ } @top;
- if (defined $left xor defined $right) {
- return defined $left ? $left : $right;
- }
- elsif (! defined $left) {
- return undef;
- }
- else {
- return { -and => [ $left, $right ] };
+ 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
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} } ) {
$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
);
if (ref($related) eq 'REF' and ref($$related) eq 'HASH') {
- $related = $self->_extract_fixed_values_for($$related, $rel);
+ $related = $self->result_source
+ ->_extract_fixed_values_for($$related, $rel);
}
my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel});
}
}
-sub _extract_fixed_values_for {
- my ($self, $dq, $alias) = @_;
- my $fixed = $self->_extract_fixed_conditions_for($dq, $alias);
- return +{ map {
- is_Value($fixed->{$_})
- ? ($_ => $fixed->{$_}{value})
- : ()
- } keys %$fixed };
-}
-
-sub _extract_fixed_conditions_for {
- my ($self, $dq, $alias) = @_;
- my (@q, %found) = ($dq);
- while (my $n = shift @q) {
- if (is_Operator($n)) {
- if (($n->{operator}{Perl}||'') =~ /^(?:==|eq)$/) {
- my ($l, $r) = @{$n->{args}};
- if (
- is_Identifier($r) and @{$r->{elements}} == 2
- and $r->{elements}[0] eq $alias
- ) {
- ($l, $r) = ($r, $l);
- }
- if (
- is_Identifier($l) and @{$l->{elements}} == 2
- and $l->{elements}[0] eq $alias
- ) {
- $found{$l->{elements}[1]} = $r;
- } elsif (($n->{operator}{Perl}||'') eq 'and') {
- push @q, @{$n->{args}};
- }
- }
- }
- }
- return \%found;
-}
-
# populate() arguments went over several incarnations
# What we ultimately support is AoH
sub _normalize_populate_args {
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.
}
}
elsif (ref $self->{cond} eq 'REF' and ref ${$self->{cond}} eq 'HASH') {
- %new_data = %{$self->_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(
$attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs
);
- $self->{_attrs}{_sqlmaker_select_args} = $attrs->{_sqlmaker_select_args};
-
$aq;
}
$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}
: []