X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=9b8260f54e1cb4a61753241f641c20decc414739;hb=d13725da15053d1372b1077bf5de9a914475ab21;hp=03b5a93ff3fef1ce334ba86fc234f21088896212;hpb=331e2209e8a151082fb8f20f11545a5472723832;p=scpubgit%2FQ-Branch.git

diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm
index 03b5a93..9b8260f 100644
--- a/lib/SQL/Abstract.pm
+++ b/lib/SQL/Abstract.pm
@@ -53,6 +53,8 @@ my @BUILTIN_UNARY_OPS = (
   { 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' },
 );
 
 #======================================================================
@@ -552,21 +554,66 @@ sub _expand_expr {
 
 sub _expand_expr_hashpair {
   my ($self, $k, $v, $logic) = @_;
-  if (!ref($v)) {
-    if ($k !~ /^-/) {
-      return +{ $k => { $self->{cmp} => $v } };
+  unless (defined($k) and length($k)) {
+    if (defined($k) and 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';
+      return $v;
     }
+    puke "Supplying an empty left hand side argument is not supported";
   }
-  if ($k eq '-nest') {
-    return $self->_expand_expr($v);
-  }
-  if ($k !~ /^-/ and my $literal = is_literal_value($v)) {
-    unless (length $k) {
-      belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
-      return \$literal;
+  if ($k =~ /^-/) {
+    if ($k eq '-nest') {
+      return $self->_expand_expr($v);
+    }
+    if ($k eq '-bool') {
+      if (ref($v)) {
+        return $self->_expand_expr($v);
+      }
+      puke "-bool => undef not supported" unless defined($v);
+      return { -ident => $v };
+    }
+    if (my ($rest) = $k =~/^-not[_ ](.*)$/) {
+      return $self->_expand_expr({ -not => { "-${rest}", $v } }, $logic);
+    }
+  } else {
+    unless (defined($v)) {
+      my $orig_op = my $op = $self->{cmp};
+      my $is =
+        $op =~ /^not$/i               ? 'is not'  # legacy
+      : $op =~ $self->{equality_op}   ? 'is'
+      : $op =~ $self->{like_op}       ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is'
+      : $op =~ $self->{inequality_op} ? 'is not'
+      : $op =~ $self->{not_like_op}   ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not'
+      : puke "unexpected operator '$orig_op' with undef operand";
+      return +{ -op => [ $is.' null', { -ident => $k } ] };
+    }
+    if (!ref($v)) {
+      return +{
+        -op => [
+          $self->{cmp},
+          { -ident => $k },
+          { -bind => [ $k, $v ] }
+        ]
+      };
+    }
+    if (ref($v) eq 'ARRAY') {
+      return $self->{sqlfalse} unless @$v;
+      $self->_debug("ARRAY($k) means distribute over elements");
+      my $this_logic = (
+        $v->[0] =~ /^-((?:and|or))$/i
+          ? ($v = [ @{$v}[1..$#$v] ], $1)
+          : ($self->{logic} || 'or')
+      );
+      return +{ "-${this_logic}" => [ map $self->_expand_expr({ $k => $_ }, $this_logic), @$v ] };
+    }
+    if (my $literal = is_literal_value($v)) {
+      unless (length $k) {
+        belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
+        return \$literal;
+      }
+      my ($sql, @bind) = @$literal;
+      return \[ $self->_quote($k).' '.$sql, @bind ];
     }
-    my ($sql, @bind) = @$literal;
-    return \[ $self->_quote($k).' '.$sql, @bind ];
   }
   return { $k => $v };
 }
@@ -719,9 +766,10 @@ 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 !(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};
@@ -861,11 +909,11 @@ sub _where_op_IDENT {
   }
 
   # in case we are called as a top level special op (no '=')
-  my $lhs = shift;
+  my $has_lhs = my $lhs = shift;
 
   $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
 
-  return $lhs
+  return $has_lhs
     ? "$lhs = $rhs"
     : $rhs
   ;
@@ -905,6 +953,36 @@ sub _where_op_VALUE {
   ;
 }
 
+
+my %unop_postfix = map +($_ => 1), 'is null', 'is not null';
+
+sub _where_op_OP {
+  my ($self, undef, $v) = @_;
+  my ($op, @args) = @$v;
+  $op =~ s/^-// if length($op) > 1;
+  local $self->{_nested_func_lhs};
+  if (@args == 1) {
+    my ($expr_sql, @bind) = $self->_recurse_where($args[0]);
+    my $final_op = join ' ', split '_', $op;
+    my $op_sql = $self->_sqlcase($final_op);
+    my $final_sql = (
+      $unop_postfix{lc($final_op)}
+        ? "${expr_sql} ${op_sql}"
+        : "${op_sql} ${expr_sql}"
+    );
+    return ($final_sql, @bind);
+  } elsif (@args == 2) {
+     my ($l, $r) = map [ $self->_recurse_where($_) ], @args;
+     return (                                                                          $l->[0].' '.$self->_sqlcase(join ' ', split '_', $op).' '.$r->[0],              @{$l}[1..$#$l], @{$r}[1..$#$r]                                                );
+  }
+  die "unhandled";
+}
+
+sub _where_op_BIND {
+  my ($self, undef, $bind) = @_;
+  return ($self->_convert('?'), $self->_bindtype(@$bind));
+}
+
 sub _where_hashpair_ARRAYREF {
   my ($self, $k, $v) = @_;