From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 4 Feb 2010 13:23:16 +0000 (+0000)
Subject: Things look saner now
X-Git-Tag: v1.70~135^2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b9a4fdaeeb2cc0b566968a740fd9063a095ade07;hp=f8135ff3cf0718478067398ec50c71a891696a75;p=dbsrgits%2FSQL-Abstract.git

Things look saner now
---

diff --git a/Changes b/Changes
index 14e1bac..e546749 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for SQL::Abstract
 
+    - Another iteration of SQL::Abstract::Test fixes and improvements
+
 revision 1.60  2009-09-22 11:03 (UTC)
 ----------------------------
     - fix a well masked error in the sql-test tokenizer
diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm
index be82511..8951e36 100644
--- a/lib/SQL/Abstract/Test.pm
+++ b/lib/SQL/Abstract/Test.pm
@@ -40,6 +40,7 @@ my @expression_terminator_sql_keywords = (
   )',
   'ON',
   'WHERE',
+  'EXISTS',
   'GROUP \s+ BY',
   'HAVING',
   'ORDER \s+ BY',
@@ -58,11 +59,14 @@ my @expression_terminator_sql_keywords = (
 # * BETWEEN without paranthesis around the ANDed arguments (which
 #   makes it a non-binary op) is detected and accomodated in 
 #   _recurse_parse()
-my $stuff_around_mathops = qr/[\w\s\`\'\)]/;
+my $stuff_around_mathops = qr/[\w\s\`\'\"\)]/;
 my @binary_op_keywords = (
   ( map
-    { " (?<=  $stuff_around_mathops) " . quotemeta $_ . "(?= $stuff_around_mathops )" }
-    (qw/< > != = <= >=/)
+    {
+      ' ^ '  . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
+      " (?<= $stuff_around_mathops)" . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
+    }
+    (qw/< > != <> = <= >=/)
   ),
   ( map
     { '\b (?: NOT \s+)?' . $_ . '\b' }
@@ -75,7 +79,7 @@ my $tokenizer_re_str = join("\n\t|\n",
   @binary_op_keywords,
 );
 
-my $tokenizer_re = qr/ \s* ( \( | \) | \? | $tokenizer_re_str ) \s* /xi;
+my $tokenizer_re = qr/ \s* ( $tokenizer_re_str | \( | \) | \? ) \s* /xi;
 
 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
 my @unrollable_ops = (
@@ -216,7 +220,7 @@ sub _eq_sql {
     _parenthesis_unroll ($_) for ($left, $right);
 
     # if operators are different
-    if ($left->[0] ne $right->[0]) {
+    if ( $left->[0] ne $right->[0] ) {
       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
         unparse($left),
         unparse($right);
@@ -224,7 +228,7 @@ sub _eq_sql {
     }
     # elsif operators are identical, compare operands
     else { 
-      if ($left->[0] eq 'EXPR' ) { # unary operator
+      if ($left->[0] eq 'LITERAL' ) { # unary
         (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
         (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
         my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
@@ -246,10 +250,7 @@ sub parse {
   # tokenize string, and remove all optional whitespace
   my $tokens = [];
   foreach my $token (split $tokenizer_re, $s) {
-    $token =~ s/\s+/ /g;
-    $token =~ s/\s+([^\w\s])/$1/g;
-    $token =~ s/([^\w\s])\s+/$1/g;
-    push @$tokens, $token if length $token;
+    push @$tokens, $token if (length $token) && ($token =~ /\S/);
   }
 
   my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
@@ -277,7 +278,7 @@ sub _recurse_parse {
     my $token = shift @$tokens;
 
     # nested expression in ()
-    if ($token eq '(') {
+    if ($token eq '(' ) {
       my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
       $token = shift @$tokens   or croak "missing closing ')' around block " . unparse ($right);
       $token eq ')'             or croak "unexpected token '$token' terminating block " . unparse ($right);
@@ -302,9 +303,9 @@ sub _recurse_parse {
       my $op = uc $token;
       my $right = _recurse_parse($tokens, PARSE_RHS);
 
-      # A between with a simple EXPR for a 1st RHS argument needs a
+      # A between with a simple LITERAL for a 1st RHS argument needs a
       # rerun of the search to (hopefully) find the proper AND construct
-      if ($op eq 'BETWEEN' and $right->[0] eq 'EXPR') {
+      if ($op eq 'BETWEEN' and $right->[0] eq 'LITERAL') {
         unshift @$tokens, $right->[1][0];
         $right = _recurse_parse($tokens, PARSE_IN_EXPR);
       }
@@ -326,10 +327,11 @@ sub _recurse_parse {
                     : [[ $op => [$right] ]];
 
     }
-    # leaf expression
+    # literal (eat everything on the right until RHS termination)
     else {
-      $left = $left ? [@$left, [EXPR => [$token] ] ]
-                    : [ EXPR => [$token] ];
+      my $right = _recurse_parse ($tokens, PARSE_RHS);
+      $left = $left ? [$left, [LITERAL => [join ' ', $token, unparse($right)||()] ] ]
+                    : [ LITERAL => [join ' ', $token, unparse($right)||()] ];
     }
   }
 }
@@ -373,23 +375,23 @@ sub _parenthesis_unroll {
         $changes++;
       }
 
-      # only one EXPR element in the parenthesis
+      # only one LITERAL element in the parenthesis
       elsif (
-        @{$child->[1]} == 1 && $child->[1][0][0] eq 'EXPR'
+        @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
       ) {
         push @children, $child->[1][0];
         $changes++;
       }
 
-      # only one element in the parenthesis which is a binary op with two EXPR sub-children
+      # only one element in the parenthesis which is a binary op with two LITERAL sub-children
       elsif (
         @{$child->[1]} == 1
           and
         grep { $child->[1][0][0] =~ /^ $_ $/xi } (@binary_op_keywords)
           and
-        $child->[1][0][1][0][0] eq 'EXPR'
+        $child->[1][0][1][0][0] eq 'LITERAL'
           and
-        $child->[1][0][1][1][0] eq 'EXPR'
+        $child->[1][0][1][1][0] eq 'LITERAL'
       ) {
         push @children, $child->[1][0];
         $changes++;
@@ -416,7 +418,7 @@ sub unparse {
   elsif (ref $tree->[0]) {
     return join (" ", map { unparse ($_) } @$tree);
   }
-  elsif ($tree->[0] eq 'EXPR') {
+  elsif ($tree->[0] eq 'LITERAL') {
     return $tree->[1][0];
   }
   elsif ($tree->[0] eq 'PAREN') {
diff --git a/t/05in_between.t b/t/05in_between.t
index aa0b13a..bf32375 100644
--- a/t/05in_between.t
+++ b/t/05in_between.t
@@ -101,14 +101,14 @@ my @in_between_tests = (
   {
     parenthesis_significant => 1,
     where => { x => { -in => \'( 1,2,lower(y) )' } },
-    stmt => "WHERE ( x IN (1, 2, lower(y) ) )",
+    stmt => "WHERE ( x IN ( 1,2,lower(y) ) )",
     bind => [],
     test => '-in with a literal scalarref',
   },
   {
     parenthesis_significant => 1,
     where => { x => { -in => \['( ( ?,?,lower(y) ) )', 1, 2] } },
-    stmt => "WHERE ( x IN (?, ?, lower(y) ) )",
+    stmt => "WHERE ( x IN ( ?,?,lower(y) ) )",  # note that outer parens are opened even though literal was requested (RIBASUSHI)
     bind => [1, 2],
     test => '-in with a literal arrayrefref',
   },
diff --git a/t/07subqueries.t b/t/07subqueries.t
index d0564aa..f14738a 100644
--- a/t/07subqueries.t
+++ b/t/07subqueries.t
@@ -35,7 +35,7 @@ $where = {
   };
 push @tests, {
   where => $where,
-  stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE ( c2 < ? AND c3 LIKE ? )) AND foo = ? )",
+  stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE (( c2 < ? AND c3 LIKE ? )) ) AND foo = ? )",
   bind => [100, "foo%", 1234],
 };