Fix -values not being handled properly with NULLs
[dbsrgits/SQL-Abstract.git] / lib / SQL / Abstract.pm
index 6dabd39..1c7ba4d 100644 (file)
@@ -10,7 +10,7 @@ use Scalar::Util ();
 # GLOBALS
 #======================================================================
 
-our $VERSION  = '1.74';
+our $VERSION  = '1.78';
 
 # This would confuse some packagers
 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
@@ -24,6 +24,7 @@ my @BUILTIN_SPECIAL_OPS = (
   {regex => qr/^ (?: not \s )? in      $/ix, handler => '_where_field_IN'},
   {regex => qr/^ ident                 $/ix, handler => '_where_op_IDENT'},
   {regex => qr/^ value                 $/ix, handler => '_where_op_VALUE'},
+  {regex => qr/^ is (?: \s+ not )?     $/ix, handler => '_where_field_IS'},
 );
 
 # unaryish operators - key maps to handler
@@ -34,7 +35,7 @@ my @BUILTIN_UNARY_OPS = (
   { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' },
   { regex => qr/^ (?: not \s )? bool     $/xi, handler => '_where_op_BOOL' },
   { regex => qr/^ ident                  $/xi, handler => '_where_op_IDENT' },
-  { regex => qr/^ value                  $/ix, handler => '_where_op_VALUE' },
+  { regex => qr/^ value                  $/xi, handler => '_where_op_VALUE' },
 );
 
 #======================================================================
@@ -80,9 +81,12 @@ sub new {
   $opt{cmp} ||= '=';
 
   # try to recognize which are the 'equality' and 'inequality' ops
-  # (temporary quickfix, should go through a more seasoned API)
-  $opt{equality_op}   = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i;
-  $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i;
+  # (temporary quickfix (in 2007), should go through a more seasoned API)
+  $opt{equality_op}   = qr/^( \Q$opt{cmp}\E | \= )$/ix;
+  $opt{inequality_op} = qr/^( != | <> )$/ix;
+
+  $opt{like_op}       = qr/^ (is\s+)? r?like $/xi;
+  $opt{not_like_op}   = qr/^ (is\s+)? not \s+ r?like $/xi;
 
   # SQL booleans
   $opt{sqltrue}  ||= '1=1';
@@ -685,6 +689,14 @@ sub _where_op_VALUE {
   # in case we are called as a top level special op (no '=')
   my $lhs = shift;
 
+  # special-case NULL
+  if (! defined $rhs) {
+    return $lhs
+      ? $self->_convert($self->_quote($lhs)) . ' IS NULL'
+      : undef
+    ;
+  }
+
   my @bind =
     $self->_bindtype (
       ($lhs || $self->{_nested_func_lhs}),
@@ -755,9 +767,17 @@ sub _where_hashpair_HASHREF {
 
     $self->_assert_pass_injection_guard($op);
 
+    # fixup is_not
+    $op =~ s/^is_not/IS NOT/i;
+
     # so that -not_foo works correctly
     $op =~ s/^not_/NOT /i;
 
+    # another retarded special case: foo => { $op => { -value => undef } }
+    if (ref $val eq 'HASH' and keys %$val == 1 and exists $val->{-value} and ! defined $val->{-value} ) {
+      $val = undef;
+    }
+
     my ($sql, @bind);
 
     # CASE: col-value logic modifiers
@@ -797,9 +817,14 @@ sub _where_hashpair_HASHREF {
         },
 
         UNDEF => sub {          # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
-          my $is = ($op =~ $self->{equality_op})   ? 'is'     :
-                   ($op =~ $self->{inequality_op}) ? 'is not' :
-               puke "unexpected operator '$orig_op' with undef operand";
+          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";
+
           $sql = $self->_quote($k) . $self->_sqlcase(" $is null");
         },
 
@@ -824,7 +849,22 @@ sub _where_hashpair_HASHREF {
   return ($all_sql, @all_bind);
 }
 
+sub _where_field_IS {
+  my ($self, $k, $op, $v) = @_;
+
+  my ($s) = $self->_SWITCH_refkind($v, {
+    UNDEF => sub {
+      join ' ',
+        $self->_convert($self->_quote($k)),
+        map { $self->_sqlcase($_)} ($op, 'null')
+    },
+    FALLBACK => sub {
+      puke "$op can only take undef as argument";
+    },
+  });
 
+  $s;
+}
 
 sub _where_field_op_ARRAYREF {
   my ($self, $k, $op, $vals) = @_;
@@ -844,27 +884,35 @@ sub _where_field_op_ARRAYREF {
       shift @vals;
     }
 
+    # a long standing API wart - an attempt to change this behavior during
+    # the 1.50 series failed *spectacularly*. Warn instead and leave the
+    # behavior as is
+    if (
+      @vals > 1
+        and
+      (!$logic or $logic eq 'OR')
+        and
+      ( $op =~ $self->{inequality_op} or $op =~ $self->{not_like_op} )
+    ) {
+      my $o = uc($op);
+      belch "A multi-element arrayref as an argument to the inequality op '$o' "
+          . 'is technically equivalent to an always-true 1=1 (you probably wanted '
+          . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
+      ;
+    }
+
     # distribute $op over each remaining member of @vals, append logic if exists
     return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
 
-    # LDNOTE : had planned to change the distribution logic when
-    # $op =~ $self->{inequality_op}, because of Morgan laws :
-    # with {field => {'!=' => [22, 33]}}, it would be ridiculous to generate
-    # WHERE field != 22 OR  field != 33 : the user probably means
-    # WHERE field != 22 AND field != 33.
-    # To do this, replace the above to roughly :
-    # my $logic = ($op =~ $self->{inequality_op}) ? 'AND' : 'OR';
-    # return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
-
   }
   else {
     # try to DWIM on equality operators
-    # LDNOTE : not 100% sure this is the correct thing to do ...
-    return ($self->{sqlfalse}) if $op =~ $self->{equality_op};
-    return ($self->{sqltrue})  if $op =~ $self->{inequality_op};
-
-    # otherwise
-    puke "operator '$op' applied on an empty array (field '$k')";
+    return
+      $op =~ $self->{equality_op}   ? $self->{sqlfalse}
+    : $op =~ $self->{like_op}       ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse}
+    : $op =~ $self->{inequality_op} ? $self->{sqltrue}
+    : $op =~ $self->{not_like_op}   ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue}
+    : puke "operator '$op' applied on an empty array (field '$k')";
   }
 }
 
@@ -1227,10 +1275,11 @@ sub _quote {
   else {
     puke "Unsupported quote_char format: $_[0]->{quote_char}";
   }
+  my $esc = $_[0]->{escape_char} || $r;
 
   # parts containing * are naturally unquoted
   return join( $_[0]->{name_sep}||'', map
-    { $_ eq '*' ? $_ : $l . $_ . $r }
+    { $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } }
     ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] )
   );
 }
@@ -1815,6 +1864,21 @@ that generates SQL like this:
 Quoting is useful if you have tables or columns names that are reserved
 words in your database's SQL dialect.
 
+=item escape_char
+
+This is the character that will be used to escape L</quote_char>s appearing
+in an identifier before it has been quoted.
+
+The paramter default in case of a single L</quote_char> character is the quote
+character itself.
+
+When opening-closing-style quoting is used (L</quote_char> is an arrayref)
+this parameter defaults to the B<closing (right)> L</quote_char>. Occurences
+of the B<opening (left)> L</quote_char> within the identifier are currently left
+untouched. The default for opening-closing-style quotes may change in future
+versions, thus you are B<strongly encouraged> to specify the escape character
+explicitly.
+
 =item name_sep
 
 This is the character that separates a table and column name.  It is