X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract%2FTest.pm;h=c802be16fa08b7c59ac5b2b36c701d3083c88140;hb=b343752666c091274fe82eedeadcc39e64a7816c;hp=93854d004991c0b84f3f243c06a7e1265fee95a8;hpb=01dd4e4f8c50115f6d6f7960d381a0259f4d2620;p=scpubgit%2FQ-Branch.git diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm index 93854d0..c802be1 100644 --- a/lib/SQL/Abstract/Test.pm +++ b/lib/SQL/Abstract/Test.pm @@ -5,26 +5,22 @@ use warnings; use base qw/Test::Builder::Module Exporter/; use Data::Dumper; use Test::Builder; +use Test::Deep (); use SQL::Abstract::Tree; 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 $order_by_asc_significant = 0; + our $sql_differ; # keeps track of differing portion between SQLs our $tb = __PACKAGE__->builder; -# All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics -my @unrollable_ops = ( - 'ON', - 'WHERE', - 'GROUP \s+ BY', - 'HAVING', - 'ORDER \s+ BY', -); - sub is_same_sql_bind { my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; @@ -86,17 +82,21 @@ sub is_same_bind { sub _sql_differ_diag { my ($sql1, $sql2) = @_; - $tb->diag("SQL expressions differ\n" + $tb->${\( $tb->in_todo ? 'note' : 'diag')} ( + "SQL expressions differ\n" ." got: $sql1\n" ."expected: $sql2\n" ."differing in :\n$sql_differ\n" - ); + ); } sub _bind_differ_diag { my ($bind_ref1, $bind_ref2) = @_; - $tb->diag("BIND values differ\n" + local $Data::Dumper::Maxdepth; + + $tb->${\( $tb->in_todo ? 'note' : 'diag')} ( + "BIND values differ\n" ." got: " . Dumper($bind_ref1) ."expected: " . Dumper($bind_ref2) ); @@ -109,22 +109,16 @@ sub eq_sql_bind { } -sub eq_bind { - my ($bind_ref1, $bind_ref2) = @_; - - local $Data::Dumper::Useqq = 1; - local $Data::Dumper::Sortkeys = 1; - - return Dumper($bind_ref1) eq Dumper($bind_ref2); -} +sub eq_bind { goto &Test::Deep::eq_deeply }; 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); + undef $sql_differ; return 1 if _eq_sql($tree1, $tree2); } @@ -133,133 +127,90 @@ sub _eq_sql { # one is defined the other not if ( (defined $left) xor (defined $right) ) { + $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) ); return 0; } + # one is undefined, then so is the other elsif (not defined $left) { return 1; } + + # both are empty + elsif (@$left == 0 and @$right == 0) { + return 1; + } + + # one is empty + if (@$left == 0 or @$right == 0) { + $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) ); + return 0; + } + # 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 ("[%s] != [%s]\nleft: %s\nright: %s\n", map + { ref $_ ? $sqlat->unparse ($_) : $_ } + ($left->[0], $right->[0], $left, $right) + ); return 0; } - # one is a list, so is the other + + # both are lists elsif (ref $left->[0]) { for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) { - return 0 if (not _eq_sql ($left->[$i], $right->[$i]) ); + if (not _eq_sql ($left->[$i], $right->[$i]) ) { + if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) { + $sql_differ ||= ''; + $sql_differ .= "\n" unless $sql_differ =~ /\n\z/; + $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ); + } + return 0; + } } return 1; } - # both are an op-list combo + + # both are ops else { # unroll parenthesis if possible/allowed - _parenthesis_unroll ($_) for ($left, $right); + unless ( $parenthesis_significant ) { + $sqlat->_parenthesis_unroll($_) for $left, $right; + } + + # unroll ASC order by's + unless ($order_by_asc_significant) { + $sqlat->_strip_asc_from_order_by($_) for $left, $right; + } - # 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 - else { - 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); - $sql_differ = "[$l] != [$r]\n" if not $eq; - return $eq; - } - else { - my $eq = _eq_sql($left->[1], $right->[1]); - $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq; - return $eq; - } - } - } -} - -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 LITERAL element in the parenthesis - elsif ( - @{$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 LITERAL sub-children - elsif ( - @{$child->[1]} == 1 - and - grep { $child->[1][0][0] =~ /^ $_ $/xi } (SQL::Abstract::Tree::_binary_op_keywords()) - and - $child->[1][0][1][0][0] eq 'LITERAL' - and - $child->[1][0][1][1][0] eq 'LITERAL' - ) { - push @children, $child->[1][0]; - $changes++; - } - - # otherwise no more mucking for this pass - else { - push @children, $child; - } + # literals have a different arg-sig + elsif ($left->[0] eq '-LITERAL') { + (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); + $sql_differ = "[$l] != [$r]\n" if not $eq; + return $eq; } - $ast->[1] = \@children; - - } while ($changes); - + # if operators are identical, compare operands + else { + my $eq = _eq_sql($left->[1], $right->[1]); + $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq; + return $eq; + } + } } -sub parse { goto &SQL::Abstract::Tree::parse } - -sub unparse { goto &SQL::Abstract::Tree::unparse } - - +sub parse { $sqlat->parse(@_) } 1; @@ -383,7 +334,13 @@ 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; +parenthesis. Useful while testing C vs C. +Defaults to false; + +=head2 $order_by_asc_significant + +If true SQL comparison will consider C and +C to be different. Default is false; =head2 $sql_differ