X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=4b72804ce0ed29e8044dec67a089662ed213c74d;hb=4efe8199d3482d0b0ec4e326e62c02fa55705fcc;hp=dc21ce00efc03b29b72e943452274bac40d2e39a;hpb=ee731876b8ac70a8ba04d410ada6a3c5a2c5e760;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index dc21ce0..4b72804 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -919,230 +919,6 @@ sub _recurse_where { } } - - -#====================================================================== -# WHERE: top-level ARRAYREF -#====================================================================== - - -sub _where_ARRAYREF { - my ($self, $where, $logic) = @_; - - $logic = uc($logic || $self->{logic}); - $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic"; - - my @clauses = @$where; - - my (@sql_clauses, @all_bind); - # need to use while() so can shift() for pairs - 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, { - - # skip empty elements, otherwise get invalid trailing AND stuff - ARRAYREF => sub {$self->_recurse_where($el) if @$el}, - - ARRAYREFREF => sub { - my ($s, @b) = @$$el; - $self->_assert_bindval_matches_bindtype(@b); - ($s, @b); - }, - - HASHREF => sub {$self->_recurse_where($el, 'and') if %$el}, - - SCALARREF => sub { ($$el); }, - - SCALAR => sub { - # top-level arrayref with scalars, recurse in pairs - $self->_recurse_where({$el => shift(@clauses)}) - }, - - UNDEF => sub {puke "Supplying an empty left hand side argument is not supported in array-pairs" }, - }); - - if ($sql) { - push @sql_clauses, $sql; - push @all_bind, @bind; - } - } - - return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind); -} - -#====================================================================== -# WHERE: top-level ARRAYREFREF -#====================================================================== - -sub _where_ARRAYREFREF { - my ($self, $where) = @_; - my ($sql, @bind) = @$$where; - $self->_assert_bindval_matches_bindtype(@bind); - return ($sql, @bind); -} - -#====================================================================== -# WHERE: top-level HASHREF -#====================================================================== - -sub _where_HASHREF { - my ($self, $where) = @_; - my (@sql_clauses, @all_bind); - - for my $k (sort keys %$where) { - my $v = $where->{$k}; - - # ($k => $v) is either a special unary op or a regular hashpair - my ($sql, @bind) = do { - if ($k =~ /^-./) { - # put the operator in canonical form - my $op = $k; - $op = substr $op, 1; # remove initial dash - $op =~ s/^\s+|\s+$//g;# remove leading/trailing space - $op =~ s/\s+/ /g; # compress whitespace - - # so that -not_foo works correctly - $op =~ s/^not_/NOT /i; - - $self->_debug("Unary OP(-$op) within hashref, recursing..."); - my ($s, @b) = $self->_where_unary_op($op, $v); - - # top level vs nested - # we assume that handled unary ops will take care of their ()s - $s = "($s)" unless ( - List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}} - or - ( 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); - } - }; - - push @sql_clauses, $sql; - push @all_bind, @bind; - } - - return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind); -} - -sub _where_unary_op { - my ($self, $op, $rhs) = @_; - - $op =~ s/^-// if length($op) > 1; - - # 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 (my $op_entry = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) { - my $handler = $op_entry->{handler}; - - if (not ref $handler) { - 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 => [ -$op => COND1, -$op => COND2 ... ]"; - } - return $self->$handler($op, $rhs); - } - elsif (ref $handler eq 'CODE') { - return $handler->($self, $op, $rhs); - } - else { - puke "Illegal handler for operator $op - expecting a method name or a coderef"; - } - } - - $self->_debug("Generic unary OP: $op - recursing as function"); - - $self->_assert_pass_injection_guard($op); - - my ($sql, @bind) = $self->_SWITCH_refkind($rhs, { - SCALAR => sub { - puke "Illegal use of top-level '-$op'" - unless defined $self->{_nested_func_lhs}; - - return ( - $self->_convert('?'), - $self->_bindtype($self->{_nested_func_lhs}, $rhs) - ); - }, - FALLBACK => sub { - $self->_recurse_where($rhs) - }, - }); - - $sql = sprintf('%s %s', - $self->_sqlcase($op), - $sql, - ); - - return ($sql, @bind); -} - -sub _where_op_NEST { - my ($self, $op, $v) = @_; - - $self->_SWITCH_refkind($v, { - - SCALAR => sub { # permissively interpreted as SQL - belch "literal SQL should be -nest => \\'scalar' " - . "instead of -nest => 'scalar' "; - return ($v); - }, - - UNDEF => sub { - puke "-$op => undef not supported"; - }, - - FALLBACK => sub { - $self->_recurse_where($v); - }, - - }); -} - - -sub _where_op_BOOL { - my ($self, $op, $v) = @_; - - my ($s, @b) = $self->_SWITCH_refkind($v, { - SCALAR => sub { # interpreted as SQL column - $self->_convert($self->_quote($v)); - }, - - UNDEF => sub { - puke "-$op => undef not supported"; - }, - - FALLBACK => sub { - $self->_recurse_where($v); - }, - }); - - $s = "(NOT $s)" if $op =~ /^not/i; - ($s, @b); -} - - sub _where_op_IDENT { my $self = shift; my ($op, $rhs) = splice @_, -2;