$opt{expand_unary} = {};
+ $opt{expand} = {
+ -ident => '_expand_ident',
+ -value => '_expand_value',
+ -not => '_expand_not',
+ -bool => sub {
+ my ($self, undef, $v) = @_;
+ if (ref($v)) {
+ return $self->_expand_expr($v);
+ }
+ puke "-bool => undef not supported" unless defined($v);
+ return $self->_expand_ident(-ident => $v);
+ },
+ };
+
return bless \%opt, $class;
}
sub expand_expr {
my ($self, $expr, $default_scalar_to) = @_;
local our $Default_Scalar_To = $default_scalar_to if $default_scalar_to;
- $self->_expand_expr($expr, undef);
+ $self->_expand_expr($expr);
}
sub render_aqt {
}
sub _expand_expr {
- my ($self, $expr, $logic, $default_scalar_to) = @_;
- local our $Default_Scalar_To = $default_scalar_to if $default_scalar_to;
+ my ($self, $expr, $logic) = @_;
our $Expand_Depth ||= 0; local $Expand_Depth = $Expand_Depth + 1;
return undef unless defined($expr);
if (ref($expr) eq 'HASH') {
- if (keys %$expr > 1) {
+ return undef unless my $kc = keys %$expr;
+ if ($kc > 1) {
$logic ||= 'and';
return +{ -op => [
$logic,
- map $self->_expand_expr_hashpair($_ => $expr->{$_}, $logic),
+ map $self->_expand_expr({ $_ => $expr->{$_} }, $logic),
sort keys %$expr
] };
}
- return undef unless keys %$expr;
- return $self->_expand_expr_hashpair(%$expr, $logic);
+ my ($key, $value) = %$expr;
+ if (my $exp = $self->{expand}{$key}) {
+ return $self->$exp($key, $value);
+ }
+ return $self->_expand_expr_hashpair($key, $value, $logic);
}
if (ref($expr) eq 'ARRAY') {
my $logic = lc($logic || $self->{logic});
die "notreached";
}
}
+ # ???
+ # return $res[0] if @res == 1;
return { -op => [ $logic, @res ] };
}
if (my $literal = is_literal_value($expr)) {
return +{ -literal => $literal };
}
if (!ref($expr) or Scalar::Util::blessed($expr)) {
- if (my $d = $Default_Scalar_To) {
+ if (my $d = our $Default_Scalar_To) {
return $self->_expand_expr({ $d => $expr });
}
if (my $m = our $Cur_Col_Meta) {
}
return $self->_expand_expr($v);
}
- if ($k eq '-bool') {
- if (ref($v)) {
- return $self->_expand_expr($v);
- }
- puke "-bool => undef not supported" unless defined($v);
- return $self->_expand_ident(-ident => $v);
- }
- if ($k eq '-not') {
- return { -op => [ 'not', $self->_expand_expr($v) ] };
- }
if (my ($rest) = $k =~/^-not[_ ](.*)$/) {
return +{ -op => [
'not',
- $self->_expand_expr_hashpair("-${rest}", $v, $logic)
+ $self->_expand_expr({ "-${rest}", $v }, $logic)
] };
}
if (my ($logic) = $k =~ /^-(and|or)$/i) {
{
my $op = $k;
$op =~ s/^-// if length($op) > 1;
-
+
# top level special ops are illegal in general
# note that, arguably, if it makes no sense at top level, it also
# makes no sense on the other side of an = sign or similar but DBIC
return { -op => [ $op, $v ] };
}
}
- if ($k eq '-value') {
- return +{ -bind => [ our $Cur_Col_Meta, $v ] };
- }
if (my $custom = $self->{expand_unary}{$k}) {
return $self->$custom($v);
}
and not defined $v->{-value}
)
) {
- return $self->_expand_expr_hashpair($k => { $self->{cmp} => undef });
+ return $self->_expand_expr({ $k => { $self->{cmp} => undef } });
}
if (!ref($v) or Scalar::Util::blessed($v)) {
my $d = our $Default_Scalar_To;
-op => [
$self->{cmp},
$self->_expand_ident(-ident => $k),
- ($d ? { $d => $v } : { -bind => [ $k, $v ] })
+ ($d
+ ? $self->_expand_expr($d => $v)
+ : { -bind => [ $k, $v ] }
+ )
]
};
}
if (keys %$v > 1) {
return { -op => [
'and',
- map $self->_expand_expr_hashpair($k => { $_ => $v->{$_} }),
+ map $self->_expand_expr({ $k => { $_ => $v->{$_} } }),
sort keys %$v
] };
}
return undef unless keys %$v;
my ($vk, $vv) = %$v;
- $vk =~ s/^-//;
- $vk = lc($vk);
- $self->_assert_pass_injection_guard($vk);
- if ($vk =~ s/ [_\s]? \d+ $//x ) {
+ my $op = join ' ', split '_', (map lc, $vk =~ /^-?(.*)$/)[0];
+ $self->_assert_pass_injection_guard($op);
+ if ($op =~ s/ [_\s]? \d+ $//x ) {
belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
- . "You probably wanted ...-and => [ -$vk => COND1, -$vk => COND2 ... ]";
+ . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
}
- if ($vk =~ /^(?:not[ _])?between$/) {
+ if ($op =~ /^(?:not )?between$/) {
local our $Cur_Col_Meta = $k;
my @rhs = map $self->_expand_expr($_),
ref($vv) eq 'ARRAY' ? @$vv : $vv;
or
(@rhs == 2 and defined($rhs[0]) and defined($rhs[1]))
) {
- puke "Operator '${\uc($vk)}' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
+ puke "Operator '${\uc($op)}' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
}
return +{ -op => [
- join(' ', split '_', $vk),
+ $op,
$self->_expand_ident(-ident => $k),
@rhs
] }
}
- if ($vk =~ /^(?:not[ _])?in$/) {
+ if ($op =~ /^(?:not )?in$/) {
if (my $literal = is_literal_value($vv)) {
my ($sql, @bind) = @$literal;
my $opened_sql = $self->_open_outer_paren($sql);
return +{ -op => [
- $vk, $self->_expand_ident(-ident => $k),
+ $op, $self->_expand_ident(-ident => $k),
[ { -literal => [ $opened_sql, @bind ] } ]
] };
}
my $undef_err =
'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
- . "-${\uc($vk)} operator was given an undef-containing list: !!!AUDIT YOUR CODE "
+ . "-${\uc($op)} operator was given an undef-containing list: !!!AUDIT YOUR CODE "
. 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract '
. 'will emit the logically correct SQL instead of raising this exception)'
;
- puke("Argument passed to the '${\uc($vk)}' operator can not be undefined")
+ puke("Argument passed to the '${\uc($op)}' operator can not be undefined")
if !defined($vv);
my @rhs = map $self->_expand_expr($_),
map { ref($_) ? $_ : { -bind => [ $k, $_ ] } }
map { defined($_) ? $_: puke($undef_err) }
(ref($vv) eq 'ARRAY' ? @$vv : $vv);
- return $self->${\($vk =~ /^not/ ? 'sqltrue' : 'sqlfalse')} unless @rhs;
+ return $self->${\($op =~ /^not/ ? 'sqltrue' : 'sqlfalse')} unless @rhs;
return +{ -op => [
- join(' ', split '_', $vk),
+ $op,
$self->_expand_ident(-ident => $k),
\@rhs
] };
}
- if ($vk eq 'ident') {
+ if ($op eq 'ident') {
if (! defined $vv or (ref($vv) and ref($vv) eq 'ARRAY')) {
- puke "-$vk requires a single plain scalar argument (a quotable identifier) or an arrayref of identifier parts";
+ puke "-$op requires a single plain scalar argument (a quotable identifier) or an arrayref of identifier parts";
}
return +{ -op => [
$self->{cmp},
$self->_expand_ident(-ident => $vv),
] };
}
- if ($vk eq 'value') {
- return $self->_expand_expr_hashpair($k, undef) unless defined($vv);
+ if ($op eq 'value') {
+ return $self->_expand_expr({ $k, undef }) unless defined($vv);
return +{ -op => [
$self->{cmp},
$self->_expand_ident(-ident => $k),
{ -bind => [ $k, $vv ] }
] };
}
- if ($vk =~ /^is(?:[ _]not)?$/) {
- puke "$vk can only take undef as argument"
+ if ($op =~ /^is(?: not)?$/) {
+ puke "$op can only take undef as argument"
if defined($vv)
and not (
ref($vv) eq 'HASH'
and exists($vv->{-value})
and !defined($vv->{-value})
);
- $vk =~ s/_/ /g;
- return +{ -op => [ $vk.' null', $self->_expand_ident(-ident => $k) ] };
+ return +{ -op => [ $op.' null', $self->_expand_ident(-ident => $k) ] };
}
- if ($vk =~ /^(and|or)$/) {
+ if ($op =~ /^(and|or)$/) {
if (ref($vv) eq 'HASH') {
return +{ -op => [
- $vk,
- map $self->_expand_expr_hashpair($k, { $_ => $vv->{$_} }),
+ $op,
+ map $self->_expand_expr({ $k, { $_ => $vv->{$_} } }),
sort keys %$vv
] };
}
}
- if (my $us = List::Util::first { $vk =~ $_->{regex} } @{$self->{special_ops}}) {
- return { -op => [ $vk, { -ident => $k }, $vv ] };
+ if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) {
+ return { -op => [ $op, $self->_expand_ident(-ident => $k), $vv ] };
}
- if (my $us = List::Util::first { $vk =~ $_->{regex} } @{$self->{unary_ops}}) {
+ if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
return { -op => [
$self->{cmp},
$self->_expand_ident(-ident => $k),
- { -op => [ $vk, $vv ] }
+ { -op => [ $op, $vv ] }
] };
}
if (ref($vv) eq 'ARRAY') {
: (-or => @$vv)
);
if (
- $vk =~ $self->{inequality_op}
- or join(' ', split '_', $vk) =~ $self->{not_like_op}
+ $op =~ $self->{inequality_op}
+ or $op =~ $self->{not_like_op}
) {
if (lc($logic) eq '-or' and @values > 1) {
- my $op = uc join ' ', split '_', $vk;
- belch "A multi-element arrayref as an argument to the inequality op '$op' "
+ belch "A multi-element arrayref as an argument to the inequality op '${\uc($op)}' "
. 'is technically equivalent to an always-true 1=1 (you probably wanted '
. "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
;
}
unless (@values) {
# try to DWIM on equality operators
- my $op = join ' ', split '_', $vk;
return
$op =~ $self->{equality_op} ? $self->sqlfalse
: $op =~ $self->{like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->sqlfalse
}
return +{ -op => [
$logic =~ /^-(.*)$/,
- map $self->_expand_expr_hashpair($k => { $vk => $_ }),
+ map $self->_expand_expr({ $k => { $vk => $_ } }),
@values
] };
}
and not defined $vv->{-value}
)
) {
- my $op = join ' ', split '_', $vk;
my $is =
$op =~ /^not$/i ? 'is not' # legacy
: $op =~ $self->{equality_op} ? 'is'
}
local our $Cur_Col_Meta = $k;
return +{ -op => [
- $vk,
- $self->_expand_ident(-ident => $k),
- $self->_expand_expr($vv)
+ $op,
+ $self->_expand_ident(-ident => $k),
+ $self->_expand_expr($vv)
] };
}
if (ref($v) eq 'ARRAY') {
return +{ -ident => \@parts };
}
+sub _expand_value {
+ +{ -bind => [ our $Cur_Col_Meta, $_[2] ] };
+}
+
+sub _expand_not {
+ +{ -op => [ 'not', $_[0]->_expand_expr($_[2]) ] };
+}
+
sub _recurse_where {
my ($self, $where, $logic) = @_;
my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
if ($us and @args > 1) {
puke "Special op '${op}' requires first value to be identifier"
- unless my ($k) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0];
+ unless my ($ident) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0];
+ my $k = join(($self->{name_sep}||'.'), @$ident);
local our $Expand_Depth = 1;
return $self->${\($us->{handler})}($k, $op, $args[1]);
}
projects / scpubgit/Q-Branch.git / blobdiff