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
use List::Util ();
$call_cond = { @_ };
}
+ if (blessed($call_cond) and $call_cond->isa('Data::Query::ExprBuilder')) {
+ $call_cond = \$call_cond->{expr};
+ }
+
# see if we can keep the cache (no $rs changes)
my $cache;
my %safe = (alias => 1, cache => 1);
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
$sql_maker->{name_sep} = '';
}
+ # 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->_parse_rs_attrs ({ having => $attrs->{having} });
+ my $having_sql = $sql_maker->_render_sqla(where => $attrs->{having});
+
my %seen_having;
# search for both a proper quoted qualified string, for a naive unquoted scalarref
# and if all fails for an utterly naive quoted scalar-with-function
while ($having_sql =~ /
- $rquote $sep $lquote (.+?) $rquote
+ (?: $rquote $sep)? $lquote (.+?) $rquote
|
[\s,] \w+ \. (\w+) [\s,]
|
if (! $needs_subq) {
# Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus
# a condition containing 'me' or other table prefixes will not work
- # at all. Tell SQLMaker to dequalify idents via a gross hack.
- $cond = do {
- my $sqla = $rsrc->storage->sql_maker;
- local $sqla->{_dequalify_idents} = 1;
- \[ $sqla->_recurse_where($self->{cond}) ];
- };
+ # at all - so we convert the WHERE to a dq tree now, dequalify all
+ # identifiers found therein via a scan across the tree, and then use
+ # \{} style to pass the result onwards for use in the final query
+ if ($self->{cond}) {
+ $cond = do {
+ my $converter = $rsrc->storage->sql_maker->converter;
+ scan_dq_nodes({
+ DQ_IDENTIFIER ,=> sub { $_ = [ $_->[-1] ] for $_[0]->{elements} }
+ }, my $where_dq = $converter->_where_to_dq($self->{cond}));
+ \$where_dq;
+ };
+ }
}
else {
# we got this far - means it is time to wrap a subquery
my $subrs = (ref $self)->new($rsrc, $attrs);
if (@$idcols == 1) {
- $cond = { $idcols->[0] => { -in => $subrs->as_query } };
+ $cond = { $idcols->[0] => { -in => \$subrs->_as_select_dq } };
}
elsif ($storage->_use_multicolumn_in) {
# no syntax for calling this properly yet
# !!! EXPERIMENTAL API !!! WILL CHANGE !!!
- $cond = $storage->sql_maker->_where_op_multicolumn_in (
- $idcols, # how do I convey a list of idents...? can binds reside on lhs?
- $subrs->as_query
+ my $left = $storage->sql_maker->_render_sqla(select_select => $idcols);
+ $left =~ s/^SELECT //i;
+ my $right = $storage->sql_maker
+ ->converter
+ ->_literal_to_dq(${$subrs->as_query});
+ $cond = \Operator(
+ { 'SQL.Naive' => 'in' },
+ [ Literal(SQL => "( $left )"), $right ],
),
}
else {
$rel,
);
+ if (ref($related) eq 'REF' and ref($$related) eq 'HASH') {
+ $related = $self->result_source
+ ->_extract_fixed_values_for($$related, $rel);
+ }
+
my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel});
my @populate = map { {%$_, %$related} } @rows_to_add;
}
}
-
# 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} ne 'HASH') {
- $self->throw_exception(
- "Can't abstract implicit construct, resultset condition not a hash"
- );
- }
- else {
+ 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.
my $collapsed_cond = $self->_collapse_cond($self->{cond});
}
}
}
+ elsif (ref $self->{cond} eq 'REF' and ref ${$self->{cond}} eq 'HASH') {
+ 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(
+ "Can't abstract implicit construct, resultset condition not a hash"
+ );
+ }
%new_data = (
%new_data,
$aq;
}
+sub _as_select_dq {
+ my $self = shift;
+ my $attrs = { %{ $self->_resolved_attrs } };
+ my $storage = $self->result_source->storage;
+ my (undef, $ident, @args) = $storage->_select_args(
+ $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs
+ );
+ $ident = $ident->from if blessed($ident);
+ $storage->sql_maker->converter->_select_to_dq(
+ $ident, @args
+ );
+}
+
=head2 find_or_new
=over 4
$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}
: []
projects / dbsrgits/DBIx-Class.git / blobdiff