X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=d4c8c04788a26c6453f7566c9948b03cc13084ec;hb=c1c0b98908a0c9d73f97ccb0c8669c24be4fe604;hp=ede6ade13de94dd004484c06f6ba9053ccf6c423;hpb=220d0694aafa6074d5205cc0cc29e63faf9eec2d;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index ede6ade..d4c8c04 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -39,26 +39,9 @@ our $AUTOLOAD; 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 #====================================================================== @@ -178,7 +161,6 @@ sub new { # 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. @@ -546,7 +528,8 @@ sub where { } 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) { @@ -590,6 +573,9 @@ sub _expand_expr { 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 ] }; } @@ -646,9 +632,7 @@ sub _expand_expr_hashpair { # 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 ] }; @@ -884,10 +868,10 @@ sub _render_expr { 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"; } @@ -919,60 +903,22 @@ sub _recurse_where { } } -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 { @@ -1020,12 +966,11 @@ my %special = ( }), '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); } @@ -1058,8 +1003,8 @@ sub _where_op_OP { 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 { @@ -1070,13 +1015,13 @@ sub _where_op_FUNC { 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; } @@ -1119,13 +1064,16 @@ sub _open_outer_paren { 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', @@ -1141,57 +1089,28 @@ sub _order_by { 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); + }; }