X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=d0aae082b1596a198b2b9aca02355631f73d2b29;hb=2d64004f36ccaf869eaa059d153df080e16ff1e4;hp=1327193e339962621ebd4f487a6bc5274c1762d9;hpb=ef071fade9e19ee9721dd8eb8414914694632246;p=dbsrgits%2FSQL-Abstract.git

diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm
index 1327193..d0aae08 100644
--- a/lib/SQL/Abstract.pm
+++ b/lib/SQL/Abstract.pm
@@ -53,6 +53,9 @@ 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' },
+  { regex => qr/^ literal                $/xi, handler => '_where_op_LITERAL' },
 );
 
 #======================================================================
@@ -547,18 +550,97 @@ sub _expand_expr {
     }
     return $self->_expand_expr_hashpair(%$expr, $logic);
   }
+  if (ref($expr) eq 'ARRAY') {
+    $logic = lc($logic || $self->{logic});
+    $logic eq 'and' or $logic eq 'or' or puke "unknown logic: $logic";
+
+    my @expr = @$expr;
+
+    my @res;
+
+    while (my ($el) = splice @expr, 0, 1) {
+      puke "Supplying an empty left hand side argument is not supported in array-pairs"
+        unless defined($el) and length($el);
+      my $elref = ref($el);
+      if (!$elref) {
+        push(@res, $self->_expand_expr({ $el, shift(@expr) }));
+      } elsif ($elref eq 'ARRAY') {
+        push(@res, $self->_expand_expr($el)) if @$el;
+      } elsif (is_literal_value($el)) {
+        push @res, $el;
+      } elsif ($elref eq 'HASH') {
+        push @res, $self->_expand_expr($el);
+      } else {
+        die "unimplemented"
+      }
+    }
+    return { '-'.$logic => \@res };
+  }
+  if (my $literal = is_literal_value($expr)) {
+    return +{ -literal => $literal };
+  }
   return $expr;
 }
 
 sub _expand_expr_hashpair {
   my ($self, $k, $v, $logic) = @_;
+  unless (defined($k) and length($k)) {
+    if (defined($k) and my $literal = 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 { -literal => $literal };
+    }
+    puke "Supplying an empty left hand side argument is not supported";
+  }
   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 +{ $k => { $self->{cmp} => $v } };
+      return +{
+        -op => [
+          $self->{cmp},
+          { -ident => $k },
+          { -bind => [ $k, $v ] }
+        ]
+      };
+    }
+    if (ref($v) eq 'HASH' and keys %$v > 1) {
+      return { -and => [
+        map $self->_expand_expr_hashpair($k => { $_ => $v->{$_} }),
+          sort keys %$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) {
@@ -566,7 +648,14 @@ sub _expand_expr_hashpair {
         return \$literal;
       }
       my ($sql, @bind) = @$literal;
-      return \[ $self->_quote($k).' '.$sql, @bind ];
+      if ($self->{bindtype} eq 'columns') {
+        for (@bind) {
+          if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
+            puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
+          }
+        }
+      }
+      return +{ -literal => [ $self->_quote($k).' '.$sql, @bind ] };
     }
   }
   return { $k => $v };
@@ -720,9 +809,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};
@@ -862,11 +952,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
   ;
@@ -906,6 +996,41 @@ 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_op_LITERAL {
+  my ($self, undef, $literal) = @_;
+  return @$literal;
+}
+
 sub _where_hashpair_ARRAYREF {
   my ($self, $k, $v) = @_;