Refactor the parenthesis unroll SQLA::Test code

Allow explicit override: $SQL::Abstract::Test::parenthesis_significant

diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm
index 82eed8f..cc57185 100644 (file)
--- a/lib/SQL/Abstract/Test.pm
+++ b/lib/SQL/Abstract/Test.pm
@@ -13,6 +13,7 @@ our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
                     $case_sensitive $sql_differ/;
 
 our $case_sensitive = 0;
+our $parenthesis_significant = 0;
 our $sql_differ; # keeps track of differing portion between SQLs
 our $tb = __PACKAGE__->builder;
 
@@ -203,68 +204,8 @@ sub _eq_sql {
   # both are an op-list combo
   else {
 
-    for my $ast ($left, $right) {
-
-      next unless (ref $ast->[1]);
-
-      # unroll parenthesis in an elaborate loop
-      my $changes;
-      do {
-
-        my @children;
-        $changes = 0;
-
-        for my $child (@{$ast->[1]}) {
-          if (not ref $child or not $child->[0] eq 'PAREN') {
-            push @children, $child;
-            next;
-          }
-
-          # unroll nested parenthesis
-          while ($child->[1][0][0] eq 'PAREN') {
-            $child = $child->[1][0];
-            $changes++;
-          }
-
-          # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
-          if (
-            ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
-              and
-            $child->[1][0][0] eq $ast->[0]
-          ) {
-            push @children, @{$child->[1][0][1]};
-            $changes++;
-          }
-
-          # if the parent operator explcitly allows it nuke the parenthesis
-          elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
-            push @children, $child->[1][0];
-            $changes++;
-          }
-
-          # only one element in the parenthesis which is a binary op with two EXPR 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'
-              and
-            $child->[1][0][1][1][0] eq 'EXPR'
-          ) {
-            push @children, $child->[1][0];
-            $changes++;
-          }
-
-          # otherwise no more mucking for this pass
-          else {
-            push @children, $child;
-          }
-        }
-
-        $ast->[1] = \@children;
-      } while ($changes);
-    }
+    # unroll parenthesis if possible/allowed
+    _parenthesis_unroll ($_) for ($left, $right);
 
     # if operators are different
     if ($left->[0] ne $right->[0]) {
@@ -291,7 +232,6 @@ sub _eq_sql {
   }
 }
 
-
 sub parse {
   my $s = shift;
 
@@ -378,7 +318,70 @@ sub _recurse_parse {
   }
 }
 
+sub _parenthesis_unroll {
+  my $ast = shift;
+
+  return if $parenthesis_significant;
+  return unless (ref $ast and ref $ast->[1]);
+
+  my $changes;
+  do {
+    my @children;
+    $changes = 0;
+
+    for my $child (@{$ast->[1]}) {
+      if (not ref $child or not $child->[0] eq 'PAREN') {
+        push @children, $child;
+        next;
+      }
+
+      # unroll nested parenthesis
+      while ($child->[1][0][0] eq 'PAREN') {
+        $child = $child->[1][0];
+        $changes++;
+      }
+
+      # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
+      if (
+        ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
+            and
+          $child->[1][0][0] eq $ast->[0]
+      ) {
+        push @children, @{$child->[1][0][1]};
+        $changes++;
+      }
 
+      # if the parent operator explcitly allows it nuke the parenthesis
+      elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
+        push @children, $child->[1][0];
+        $changes++;
+      }
+
+      # only one element in the parenthesis which is a binary op with two EXPR 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'
+          and
+        $child->[1][0][1][1][0] eq 'EXPR'
+      ) {
+        push @children, $child->[1][0];
+        $changes++;
+      }
+
+      # otherwise no more mucking for this pass
+      else {
+        push @children, $child;
+      }
+    }
+
+    $ast->[1] = \@children;
+
+  } while ($changes);
+
+}
 
 sub unparse {
   my $tree = shift;
@@ -520,6 +523,11 @@ diagnostics or talk to L<Test::Builder>.
 
 If true, SQL comparisons will be case-sensitive. Default is false;
 
+=head2 $parenthesis_significant
+
+If true, SQL comparison will preserve and report difference in nested
+parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
+
 =head2 $sql_differ
 
 When L</eq_sql> returns false, the global variable

diff --git a/t/10test.t b/t/10test.t
index c1057c6..3e43ad3 100644 (file)
--- a/t/10test.t
+++ b/t/10test.t
@@ -101,6 +101,7 @@ my @sql_tests = (
         equal => 1,
         statements => [
           q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND c = 1/,
+          q/SELECT foo FROM bar WHERE (a = 1 AND b = 1 AND c = 1)/,
           q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) AND c = 1/,
           q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 AND c = 1)/,
           q/SELECT foo FROM bar WHERE ((((a = 1))) AND (b = 1 AND c = 1))/,
@@ -123,6 +124,36 @@ my @sql_tests = (
           q/SELECT foo FROM bar WHERE ( ((a = 1) AND ( b = 1 OR (c = 1 OR d = 1) )) AND ((e = 1)) AND f = 1) /,
         ]
       },
+      {
+        equal => 0,
+        parenthesis_significant => 1,
+        statements => [
+          q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND c = 1/,
+          q/SELECT foo FROM bar WHERE (a = 1 AND b = 1 AND c = 1)/,
+          q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) AND c = 1/,
+          q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 AND c = 1)/,
+          q/SELECT foo FROM bar WHERE ((((a = 1))) AND (b = 1 AND c = 1))/,
+        ]
+      },
+      {
+        equal => 0,
+        parenthesis_significant => 1,
+        statements => [
+          q/SELECT foo FROM bar WHERE a = 1 OR b = 1 OR c = 1/,
+          q/SELECT foo FROM bar WHERE (a = 1 OR b = 1) OR c = 1/,
+          q/SELECT foo FROM bar WHERE a = 1 OR (b = 1 OR c = 1)/,
+          q/SELECT foo FROM bar WHERE a = 1 OR ((b = 1 OR (c = 1)))/,
+        ]
+      },
+      {
+        equal => 0,
+        parenthesis_significant => 1,
+        statements => [
+          q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1 OR c = 1 OR d = 1) AND (e = 1 AND f = 1)/,
+          q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 OR c = 1 OR d = 1) AND e = 1 AND (f = 1)/,
+          q/SELECT foo FROM bar WHERE ( ((a = 1) AND ( b = 1 OR (c = 1 OR d = 1) )) AND ((e = 1)) AND f = 1) /,
+        ]
+      },
 
       # WHERE condition - different
       {
@@ -722,7 +753,12 @@ for my $test (@sql_tests) {
   while (@$statements) {
     my $sql1 = shift @$statements;
     foreach my $sql2 (@$statements) {
+
+      no warnings qw/once/; # perl 5.10 is dumb
+      local $SQL::Abstract::Test::parenthesis_significant = $test->{parenthesis_significant}
+        if $test->{parenthesis_significant};
       my $equal = eq_sql($sql1, $sql2);
+
       TODO: {
         local $TODO = $test->{todo} if $test->{todo};