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
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',
-);
-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) = @_;
}
-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) = @_;
my $tree1 = $sqlat->parse($sql1);
my $tree2 = $sqlat->parse($sql2);
+ undef $sql_differ;
return 1 if _eq_sql($tree1, $tree2);
}
# 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;
}
- # 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) {
+
+ # 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 { $sqlat->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",
$sqlat->unparse($left),
- $sqlat->unparse($right);
+ $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 { $sqlat->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]}) {
- # 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]} && $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 ( $ast->[0] =~ $unrollable_ops_re ) {
- push @children, $child->[1][0];
- $changes++;
- }
-
- # only *ONE* LITERAL element
- 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
- # 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
- @{$child->[1][0][1]} == 1
- and
- $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
- and
- $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;
- }
+ # 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 { $sqlat->parse(@_) }
=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<IN (( x ))> vs C<IN ( x )>.
+Defaults to false;
+
+=head2 $order_by_asc_significant
+
+If true SQL comparison will consider C<ORDER BY foo ASC> and
+C<ORDER BY foo> to be different. Default is false;
=head2 $sql_differ
projects / dbsrgits/SQL-Abstract.git / blobdiff