}
}
-
-
-#======================================================================
-# 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;
projects / scpubgit/Q-Branch.git / commitdiff