X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=a6bbb05e5a14dfb85e5526b13183231a799aba08;hb=4baf4bbe585315493208a73e0aa71b50aded9d7d;hp=5735b4c47874069625fe7c4129483385ce477fb8;hpb=af7336670a278d46f9181c93633c015006583a30;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 5735b4c..a6bbb05 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -27,7 +27,7 @@ BEGIN { # GLOBALS #====================================================================== -our $VERSION = '1.78'; +our $VERSION = '1.81'; # This would confuse some packagers $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases @@ -78,11 +78,6 @@ sub puke (@) { sub is_literal_value ($) { ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ] : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ] - : ( - ref $_[0] eq 'HASH' and keys %{$_[0]} == 1 - and - defined $_[0]->{-ident} and ! length ref $_[0]->{-ident} - ) ? [ $_[0]->{-ident} ] : undef; } @@ -525,7 +520,10 @@ sub _where_ARRAYREF { my (@sql_clauses, @all_bind); # need to use while() so can shift() for pairs - while (my $el = shift @clauses) { + while (@clauses) { + my $el = shift @clauses; + + $el = undef if (defined $el and ! length $el); # switch according to kind of $el and get corresponding ($sql, @bind) my ($sql, @bind) = $self->_SWITCH_refkind($el, { @@ -543,10 +541,12 @@ sub _where_ARRAYREF { SCALARREF => sub { ($$el); }, - SCALAR => sub {# top-level arrayref with scalars, recurse in pairs - $self->_recurse_where({$el => shift(@clauses)})}, + SCALAR => sub { + # top-level arrayref with scalars, recurse in pairs + $self->_recurse_where({$el => shift(@clauses)}) + }, - UNDEF => sub {puke "not supported : UNDEF in arrayref" }, + UNDEF => sub {puke "Supplying an empty left hand side argument is not supported in array-pairs" }, }); if ($sql) { @@ -600,11 +600,20 @@ sub _where_HASHREF { $s = "($s)" unless ( List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}} or - defined($self->{_nested_func_lhs}) && ($self->{_nested_func_lhs} eq $k) + ( defined $self->{_nested_func_lhs} and $self->{_nested_func_lhs} eq $k ) ); ($s, @b); } else { + if (! length $k) { + if (is_literal_value ($v) ) { + belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead'; + } + else { + puke "Supplying an empty left hand side argument is not supported in hash-pairs"; + } + } + my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v); $self->$method($k, $v); } @@ -620,6 +629,11 @@ sub _where_HASHREF { sub _where_unary_op { my ($self, $op, $rhs) = @_; + # top level special ops are illegal in general + # this includes the -ident/-value ops (dual purpose unary and special) + puke "Illegal use of top-level '-$op'" + if ! defined $self->{_nested_func_lhs} and List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}}; + if (my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}) { my $handler = $op_entry->{handler}; @@ -644,8 +658,8 @@ sub _where_unary_op { my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, { SCALAR => sub { - puke "Illegal use of top-level '$op'" - unless $self->{_nested_func_lhs}; + puke "Illegal use of top-level '-$op'" + unless defined $self->{_nested_func_lhs}; return ( $self->_convert('?'), @@ -777,7 +791,7 @@ sub _where_op_VALUE { # special-case NULL if (! defined $rhs) { - return $lhs + return defined $lhs ? $self->_convert($self->_quote($lhs)) . ' IS NULL' : undef ; @@ -785,7 +799,7 @@ sub _where_op_VALUE { my @bind = $self->_bindtype ( - ($lhs || $self->{_nested_func_lhs}), + ( defined $lhs ? $lhs : $self->{_nested_func_lhs} ), $rhs, ) ; @@ -836,7 +850,10 @@ sub _where_hashpair_HASHREF { my ($self, $k, $v, $logic) = @_; $logic ||= 'and'; - local $self->{_nested_func_lhs} = $self->{_nested_func_lhs}; + local $self->{_nested_func_lhs} = defined $self->{_nested_func_lhs} + ? $self->{_nested_func_lhs} + : $k + ; my ($all_sql, @all_bind); @@ -915,10 +932,6 @@ sub _where_hashpair_HASHREF { }, FALLBACK => sub { # CASE: col => {op/func => $stuff} - - # retain for proper column type bind - $self->{_nested_func_lhs} ||= $k; - ($sql, @bind) = $self->_where_unary_op ($op, $val); $sql = join (' ', @@ -1114,7 +1127,6 @@ sub _where_field_BETWEEN { my ($func, $arg, @rest) = %$val; puke ("Only simple { -func => arg } functions accepted as sub-arguments to BETWEEN") if (@rest or $func !~ /^ \- (.+)/x); - local $self->{_nested_func_lhs} = $k; $self->_where_unary_op ($1 => $arg); }, FALLBACK => sub { @@ -1172,7 +1184,6 @@ sub _where_field_IN { my ($func, $arg, @rest) = %$val; puke ("Only simple { -func => arg } functions accepted as sub-arguments to IN") if (@rest or $func !~ /^ \- (.+)/x); - local $self->{_nested_func_lhs} = $k; $self->_where_unary_op ($1 => $arg); }, UNDEF => sub { @@ -1231,8 +1242,29 @@ sub _where_field_IN { # adding them back in the corresponding method sub _open_outer_paren { my ($self, $sql) = @_; - $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/xs; - return $sql; + + while ( my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs ) { + + # there are closing parens inside, need the heavy duty machinery + # to reevaluate the extraction starting from $sql (full reevaluation) + if ( $inner =~ /\)/ ) { + require Text::Balanced; + + my (undef, $remainder) = do { + # idiotic design - writes to $@ but *DOES NOT* throw exceptions + local $@; + Text::Balanced::extract_bracketed( $sql, '()', qr/\s*/ ); + }; + + # the entire expression needs to be a balanced bracketed thing + # (after an extract no remainder sans trailing space) + last if defined $remainder and $remainder =~ /\S/; + } + + $sql = $inner; + } + + $sql; } @@ -1952,7 +1984,7 @@ words in your database's SQL dialect. This is the character that will be used to escape Ls appearing in an identifier before it has been quoted. -The paramter default in case of a single L character is the quote +The parameter default in case of a single L character is the quote character itself. When opening-closing-style quoting is used (L is an arrayref) @@ -2219,8 +2251,6 @@ module: =item * C<\[ $sql_string, @bind_values ]> -=item * C<< { -ident => $plain_defined_string } >> - =back On failure returns C, on sucess returns an B reference