my @BUILTIN_SPECIAL_OPS = (
{regex => qr/^ (?: not \s )? between $/ix, handler => sub { die "NOPE" }},
{regex => qr/^ (?: not \s )? in $/ix, handler => sub { die "NOPE" }},
- {regex => qr/^ ident $/ix, handler => sub { die "NOPE" }},
- {regex => qr/^ value $/ix, handler => sub { die "NOPE" }},
{regex => qr/^ is (?: \s+ not )? $/ix, handler => sub { die "NOPE" }},
);
-# unaryish operators - key maps to handler
-my @BUILTIN_UNARY_OPS = (
- # the digits are backcompat stuff
- { regex => qr/^ and (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
- { regex => qr/^ or (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
- { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' },
- { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
- { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
- { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
- { regex => qr/^ op $/xi, handler => '_where_op_OP' },
- { regex => qr/^ bind $/xi, handler => '_where_op_BIND' },
- { regex => qr/^ literal $/xi, handler => '_where_op_LITERAL' },
- { regex => qr/^ func $/xi, handler => '_where_op_FUNC' },
-);
-
#======================================================================
# DEBUGGING AND ERROR REPORTING
#======================================================================
# unary operators
$opt{unary_ops} ||= [];
- push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
# rudimentary sanity-check for user supplied bits treated as functions/operators
# If a purported function matches this regular expression, an exception is thrown.
}
sub _expand_expr {
- my ($self, $expr, $logic) = @_;
+ my ($self, $expr, $logic, $default_scalar_to) = @_;
+ local our $Default_Scalar_To = $default_scalar_to if $default_scalar_to;
return undef unless defined($expr);
if (ref($expr) eq 'HASH') {
if (keys %$expr > 1) {
return +{ -literal => $literal };
}
if (!ref($expr) or Scalar::Util::blessed($expr)) {
+ if (my $d = $Default_Scalar_To) {
+ return +{ $d => $expr };
+ }
if (my $m = our $Cur_Col_Meta) {
return +{ -bind => [ $m, $expr ] };
}
# top level special ops are illegal in general
puke "Illegal use of top-level '-$op'"
- if !(defined $self->{_nested_func_lhs})
- and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}
- and not List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}};
+ if List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
}
if ($k eq '-value' and my $m = our $Cur_Col_Meta) {
return +{ -bind => [ $m, $v ] };
my ($self, $expr) = @_;
my ($k, $v, @rest) = %$expr;
die "No" if @rest;
- my %op = map +("-$_" => '_where_op_'.uc($_)),
+ my %op = map +("-$_" => '_render_'.$_),
qw(op func value bind ident literal);
if (my $meth = $op{$k}) {
- return $self->$meth(undef, $v);
+ return $self->$meth($v);
}
die "notreached: $k";
}
}
}
-sub _where_op_IDENT {
- my $self = shift;
- my ($op, $rhs) = splice @_, -2;
- if (! defined $rhs or length ref $rhs) {
- puke "-$op requires a single plain scalar argument (a quotable identifier)";
- }
-
- # in case we are called as a top level special op (no '=')
- my $has_lhs = my $lhs = shift;
-
- $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
+sub _render_ident {
+ my ($self, $ident) = @_;
- return $has_lhs
- ? "$lhs = $rhs"
- : $rhs
- ;
+ return $self->_convert($self->_quote($ident));
}
-sub _where_op_VALUE {
- my $self = shift;
- my ($op, $rhs) = splice @_, -2;
-
- # in case we are called as a top level special op (no '=')
- my $lhs = shift;
+sub _render_value {
+ my ($self, $value) = @_;
- # special-case NULL
- if (! defined $rhs) {
- return defined $lhs
- ? $self->_where_hashpair_HASHREF($lhs, { -is => undef })
- : undef
- ;
- }
-
- my @bind =
- $self->_bindtype(
- (defined $lhs ? $lhs : $self->{_nested_func_lhs}),
- $rhs,
- )
- ;
-
- return $lhs
- ? (
- $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
- @bind
- )
- : (
- $self->_convert('?'),
- @bind,
- )
- ;
+ return ($self->_convert('?'), $self->_bindtype(undef, $value));
}
-
-my %unop_postfix = map +($_ => 1), 'is null', 'is not null';
+my %unop_postfix = map +($_ => 1),
+ 'is null', 'is not null',
+ 'asc', 'desc',
+;
my %special = (
(map +($_ => do {
}), 'in', 'not in'),
);
-sub _where_op_OP {
- my ($self, undef, $v) = @_;
+sub _render_op {
+ my ($self, $v) = @_;
my ($op, @args) = @$v;
$op =~ s/^-// if length($op) > 1;
$op = lc($op);
- local $self->{_nested_func_lhs};
if (my $h = $special{$op}) {
return $self->$h(\@args);
}
die "unhandled";
}
-sub _where_op_FUNC {
- my ($self, undef, $rest) = @_;
+sub _render_func {
+ my ($self, $rest) = @_;
my ($func, @args) = @$rest;
my @arg_sql;
my @bind = map {
return ($self->_sqlcase($func).'('.join(', ', @arg_sql).')', @bind);
}
-sub _where_op_BIND {
- my ($self, undef, $bind) = @_;
+sub _render_bind {
+ my ($self, $bind) = @_;
return ($self->_convert('?'), $self->_bindtype(@$bind));
}
-sub _where_op_LITERAL {
- my ($self, undef, $literal) = @_;
+sub _render_literal {
+ my ($self, $literal) = @_;
$self->_assert_bindval_matches_bindtype(@{$literal}[1..$#$literal]);
return @$literal;
}
sub _order_by {
my ($self, $arg) = @_;
- my (@sql, @bind);
- for my $c ($self->_order_by_chunks($arg) ) {
- $self->_SWITCH_refkind($c, {
- SCALAR => sub { push @sql, $c },
- ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
- });
- }
+ return '' unless defined($arg);
+
+ my @chunks = $self->_order_by_chunks($arg);
+
+ my @sql;
+ my @bind = map {
+ my ($s, @b) = $self->_render_expr($_);
+ push @sql, $s;
+ @b;
+ } @chunks;
my $sql = @sql
? sprintf('%s %s',
sub _order_by_chunks {
my ($self, $arg) = @_;
- return $self->_SWITCH_refkind($arg, {
-
- ARRAYREF => sub {
- map { $self->_order_by_chunks($_ ) } @$arg;
- },
-
- ARRAYREFREF => sub {
- my ($s, @b) = @$$arg;
- $self->_assert_bindval_matches_bindtype(@b);
- [ $s, @b ];
- },
-
- SCALAR => sub {$self->_quote($arg)},
-
- UNDEF => sub {return () },
-
- SCALARREF => sub {$$arg}, # literal SQL, no quoting
-
- HASHREF => sub {
- # get first pair in hash
- my ($key, $val, @rest) = %$arg;
-
- return () unless $key;
-
- if (@rest or not $key =~ /^-(desc|asc)/i) {
- puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
- }
-
- my $direction = $1;
-
- my @ret;
- for my $c ($self->_order_by_chunks($val)) {
- my ($sql, @bind);
+ if (ref($arg) eq 'ARRAY') {
+ return map $self->_order_by_chunks($_), @$arg;
+ }
+ if (my $l = is_literal_value($arg)) {
+ return +{ -literal => $l };
+ }
+ if (!ref($arg)) {
+ return +{ -ident => $arg };
+ }
+ if (ref($arg) eq 'HASH') {
+ my ($key, $val, @rest) = %$arg;
- $self->_SWITCH_refkind($c, {
- SCALAR => sub {
- $sql = $c;
- },
- ARRAYREF => sub {
- ($sql, @bind) = @$c;
- },
- });
+ return () unless $key;
- $sql = $sql . ' ' . $self->_sqlcase($direction);
+ if (@rest or not $key =~ /^-(desc|asc)/i) {
+ puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
+ }
- push @ret, [ $sql, @bind];
- }
+ my $dir = $1;
- return @ret;
- },
- });
+ map +{ -op => [ $dir, $_ ] }, $self->_order_by_chunks($val);
+ };
}
projects / dbsrgits/SQL-Abstract.git / blobdiff