Add list support, and various mini-fixes

[dbsrgits/SQL-Abstract.git] / lib / SQL / Abstract / Test.pm

diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm
index 93854d0..42491f9 100644 (file)
--- a/lib/SQL/Abstract/Test.pm
+++ b/lib/SQL/Abstract/Test.pm
@@ -11,6 +11,8 @@ our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
                     &eq_sql_bind &eq_sql &eq_bind
                     $case_sensitive $sql_differ/;
 
+my $sqlat = SQL::Abstract::Tree->new;
+
 our $case_sensitive = 0;
 our $parenthesis_significant = 0;
 our $sql_differ; # keeps track of differing portion between SQLs
@@ -24,6 +26,8 @@ my @unrollable_ops = (
   'HAVING',
   'ORDER \s+ BY',
 );
+my $unrollable_ops_re = join ' | ', @unrollable_ops;
+$unrollable_ops_re = qr/$unrollable_ops_re/xi;
 
 sub is_same_sql_bind {
   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
@@ -122,8 +126,8 @@ sub eq_sql {
   my ($sql1, $sql2) = @_;
 
   # parse
-  my $tree1 = parse($sql1);
-  my $tree2 = parse($sql2);
+  my $tree1 = $sqlat->parse($sql1);
+  my $tree2 = $sqlat->parse($sql2);
 
   return 1 if _eq_sql($tree1, $tree2);
 }
@@ -139,9 +143,18 @@ sub _eq_sql {
   elsif (not defined $left) {
     return 1;
   }
+  # different amount of elements
+  elsif (@$left != @$right) {
+    $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
+    return 0;
+  }
+  # one is empty - so is the other
+  elsif (@$left == 0) {
+    return 1;
+  }
   # one is a list, the other is an op with a list
   elsif (ref $left->[0] xor ref $right->[0]) {
-    $sql_differ = sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) );
+    $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
     return 0;
   }
   # one is a list, so is the other
@@ -160,8 +173,8 @@ sub _eq_sql {
     # if operators are different
     if ( $left->[0] ne $right->[0] ) {
       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
-        unparse($left),
-        unparse($right);
+        $sqlat->unparse($left),
+        $sqlat->unparse($right);
       return 0;
     }
     # elsif operators are identical, compare operands
@@ -175,7 +188,7 @@ sub _eq_sql {
       }
       else {
         my $eq = _eq_sql($left->[1], $right->[1]);
-        $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq;
+        $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
         return $eq;
       }
     }
@@ -194,13 +207,14 @@ sub _parenthesis_unroll {
     $changes = 0;
 
     for my $child (@{$ast->[1]}) {
+      # the current node in this loop is *always* a PAREN
       if (not ref $child or not $child->[0] eq 'PAREN') {
         push @children, $child;
         next;
       }
 
       # unroll nested parenthesis
-      while ($child->[1][0][0] eq 'PAREN') {
+      while ( @{$child->[1]} && $child->[1][0][0] eq 'PAREN') {
         $child = $child->[1][0];
         $changes++;
       }
@@ -216,12 +230,12 @@ sub _parenthesis_unroll {
       }
 
       # if the parent operator explcitly allows it nuke the parenthesis
-      elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
+      elsif ( $ast->[0] =~ $unrollable_ops_re ) {
         push @children, $child->[1][0];
         $changes++;
       }
 
-      # only one LITERAL element in the parenthesis
+      # only *ONE* LITERAL element
       elsif (
         @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
       ) {
@@ -229,20 +243,56 @@ sub _parenthesis_unroll {
         $changes++;
       }
 
-      # only one element in the parenthesis which is a binary op with two LITERAL sub-children
+      # only one element in the parenthesis which is a binary op
+      # and has exactly two grandchildren
+      # the only time when we can *not* unroll this is when both
+      # the parent and the child are mathops (in which case we'll
+      # break precedence) or when the child is BETWEEN (special
+      # case)
+      elsif (
+        @{$child->[1]} == 1
+          and
+        $child->[1][0][0] =~ SQL::Abstract::Tree::_binary_op_re()
+          and
+        $child->[1][0][0] ne 'BETWEEN'
+          and
+        @{$child->[1][0][1]} == 2
+          and
+        ! (
+          $child->[1][0][0] =~ SQL::Abstract::Tree::_math_op_re()
+            and
+          $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
+        )
+      ) {
+        push @children, $child->[1][0];
+        $changes++;
+      }
+
+      # a function binds tighter than a mathop - see if our ancestor is a
+      # mathop, and our content is:
+      # a single non-mathop child with a single PAREN grandchild which
+      # would indicate mathop ( nonmathop ( ... ) )
+      # or a single non-mathop with a single LITERAL ( nonmathop ? )
       elsif (
         @{$child->[1]} == 1
           and
-        grep { $child->[1][0][0] =~ /^ $_ $/xi } (SQL::Abstract::Tree::_binary_op_keywords())
+        @{$child->[1][0][1]} == 1
           and
-        $child->[1][0][1][0][0] eq 'LITERAL'
+        $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
           and
-        $child->[1][0][1][1][0] eq 'LITERAL'
+        $child->[1][0][0] !~ SQL::Abstract::Tree::_math_op_re
+          and
+        (
+          $child->[1][0][1][0][0] eq 'PAREN'
+            or 
+          $child->[1][0][1][0][0] eq 'LITERAL'
+        )
       ) {
         push @children, $child->[1][0];
         $changes++;
       }
 
+
       # otherwise no more mucking for this pass
       else {
         push @children, $child;
@@ -255,11 +305,7 @@ sub _parenthesis_unroll {
 
 }
 
-sub parse { goto &SQL::Abstract::Tree::parse }
-
-sub unparse { goto &SQL::Abstract::Tree::unparse  }
-
-
+sub parse { $sqlat->parse(@_) }
 1;