From: Peter Rabbitson Date: Tue, 28 Apr 2009 13:27:33 +0000 (+0000) Subject: Refactor the parenthesis unroll SQLA::Test code X-Git-Tag: v1.70~174 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e40f5df91f44800922e9f9f5d1669fca9cfc14da;p=dbsrgits%2FSQL-Abstract.git 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 --- 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. 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 returns false, the global variable diff --git a/t/10test.t b/t/10test.t index c1057c6..3e43ad3 100644 --- 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};