X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract%2FTest.pm;h=2bc681e8dff4453915935db42b657a6c35cfac64;hb=6f2a5b668d6d34e8aee21c2b0cf51fdbf5dee991;hp=edda9058c12839f41efbe3e8bea3542babd62b0a;hpb=939db550bf338c5ae96b2ba075577911423e4416;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm index edda905..2bc681e 100644 --- a/lib/SQL/Abstract/Test.pm +++ b/lib/SQL/Abstract/Test.pm @@ -4,68 +4,20 @@ use strict; use warnings; use base qw/Test::Builder::Module Exporter/; use Data::Dumper; -use Carp; use Test::Builder; -use Test::Deep qw(eq_deeply); +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 + &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 our $tb = __PACKAGE__->builder; -# Parser states for _recurse_parse() -use constant PARSE_TOP_LEVEL => 0; -use constant PARSE_IN_EXPR => 1; -use constant PARSE_IN_PARENS => 2; - -# These SQL keywords always signal end of the current expression (except inside -# of a parenthesized subexpression). -# Format: A list of strings that will be compiled to extended syntax (ie. -# /.../x) regexes, without capturing parentheses. They will be automatically -# anchored to word boundaries to match the whole token). -my @expression_terminator_sql_keywords = ( - 'FROM', - '(?: - (?: - (?: \b (?: LEFT | RIGHT | FULL ) \s+ )? - (?: \b (?: CROSS | INNER | OUTER ) \s+ )? - )? - JOIN - )', - 'ON', - 'WHERE', - 'GROUP \s+ BY', - 'HAVING', - 'ORDER \s+ BY', - 'LIMIT', - 'OFFSET', - 'FOR', - 'UNION', - 'INTERSECT', - 'EXCEPT', -); - -my $tokenizer_re_str = join('|', - map { '\b' . $_ . '\b' } - @expression_terminator_sql_keywords, 'AND', 'OR' -); - -my $tokenizer_re = qr/ - \s* - ( - \( - | - \) - | - $tokenizer_re_str - ) - \s* -/xi; - - sub is_same_sql_bind { my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; @@ -74,7 +26,7 @@ sub is_same_sql_bind { my $same_bind = eq_bind($bind_ref1, $bind_ref2); # call Test::Builder::ok - $tb->ok($same_sql && $same_bind, $msg); + my $ret = $tb->ok($same_sql && $same_bind, $msg); # add debugging info if (!$same_sql) { @@ -83,6 +35,9 @@ sub is_same_sql_bind { if (!$same_bind) { _bind_differ_diag($bind_ref1, $bind_ref2); } + + # pass ok() result further + return $ret; } sub is_same_sql { @@ -92,12 +47,15 @@ sub is_same_sql { my $same_sql = eq_sql($sql1, $sql2); # call Test::Builder::ok - $tb->ok($same_sql, $msg); + my $ret = $tb->ok($same_sql, $msg); # add debugging info if (!$same_sql) { _sql_differ_diag($sql1, $sql2); } + + # pass ok() result further + return $ret; } sub is_same_bind { @@ -107,12 +65,15 @@ sub is_same_bind { my $same_bind = eq_bind($bind_ref1, $bind_ref2); # call Test::Builder::ok - $tb->ok($same_bind, $msg); + my $ret = $tb->ok($same_bind, $msg); # add debugging info if (!$same_bind) { _bind_differ_diag($bind_ref1, $bind_ref2); } + + # pass ok() result further + return $ret; } sub _sql_differ_diag { @@ -144,131 +105,107 @@ sub eq_sql_bind { sub eq_bind { my ($bind_ref1, $bind_ref2) = @_; - return eq_deeply($bind_ref1, $bind_ref2); + local $Data::Dumper::Useqq = 1; + local $Data::Dumper::Sortkeys = 1; + + return Dumper($bind_ref1) eq Dumper($bind_ref2); } 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 _eq_sql($tree1, $tree2); + undef $sql_differ; + return 1 if _eq_sql($tree1, $tree2); } sub _eq_sql { my ($left, $right) = @_; - # ignore top-level parentheses - while ($left and $left->[0] and $left->[0] eq 'PAREN') {$left = $left->[1]} - while ($right and $right->[0] and $right->[0] eq 'PAREN') {$right = $right->[1]} - # 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; } - # if operators are different - elsif ($left->[0] ne $right->[0]) { - $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", - unparse($left), - unparse($right); - return 0; - } - # elsif operators are identical, compare operands - else { - if ($left->[0] eq 'EXPR' ) { # unary operator - (my $l = " $left->[1] " ) =~ s/\s+/ /g; - (my $r = " $right->[1] ") =~ s/\s+/ /g; - my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r); - $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq; - return $eq; - } - else { # binary operator - return _eq_sql($left->[1][0], $right->[1][0]) # left operand - && _eq_sql($left->[1][1], $right->[1][1]); # right operand - } - } -} - -sub parse { - my $s = shift; - - # tokenize string, and remove all optional whitespace - my $tokens = []; - foreach my $token (split $tokenizer_re, $s) { - $token =~ s/\s+/ /g; - $token =~ s/\s+([^\w\s])/$1/g; - $token =~ s/([^\w\s])\s+/$1/g; - push @$tokens, $token if $token !~ /^$/; + # both are empty + elsif (@$left == 0 and @$right == 0) { + return 1; } - my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL); - return $tree; -} - -sub _recurse_parse { - my ($tokens, $state) = @_; + # 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; + } - my $left; - while (1) { # left-associative parsing + # one is a list, the other is an op with a list + elsif (ref $left->[0] xor ref $right->[0]) { + $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map + { ref $_ ? $sqlat->unparse ($_) : $_ } + ($left->[0], $right->[0], $left, $right) + ); + return 0; + } - my $lookahead = $tokens->[0]; - return $left if !defined($lookahead) - || ($state == PARSE_IN_PARENS && $lookahead eq ')') - || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi } - '\)', @expression_terminator_sql_keywords - ); + # both are lists + elsif (ref $left->[0]) { + for (my $i = 0; $i <= $#$left or $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; + } - my $token = shift @$tokens; + # both are ops + else { - # nested expression in () - if ($token eq '(') { - my $right = _recurse_parse($tokens, PARSE_IN_PARENS); - $token = shift @$tokens or croak "missing ')'"; - $token eq ')' or croak "unexpected token : $token"; - $left = $left ? [CONCAT => [$left, [PAREN => $right]]] - : [PAREN => $right]; + # unroll parenthesis if possible/allowed + unless ( $parenthesis_significant ) { + $sqlat->_parenthesis_unroll($_) for $left, $right; } - # AND/OR - elsif ($token eq 'AND' || $token eq 'OR') { - my $right = _recurse_parse($tokens, PARSE_IN_EXPR); - $left = [$token => [$left, $right]]; + + 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) + ; + return 0; } - # expression terminator keywords (as they start a new expression) - elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) { - my $right = _recurse_parse($tokens, PARSE_IN_EXPR); - $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]] - : [CONCAT => [[EXPR => $token], [PAREN => $right]]]; + + # 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; } - # leaf expression + + # if operators are identical, compare operands else { - $left = $left ? [CONCAT => [$left, [EXPR => $token]]] - : [EXPR => $token]; + 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 unparse { - my $tree = shift; - my $dispatch = { - EXPR => sub {$tree->[1] }, - PAREN => sub {"(" . unparse($tree->[1]) . ")" }, - CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}}, - AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}}, - OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}}, - }; - $dispatch->{$tree->[0]}->(); -} - - +sub parse { $sqlat->parse(@_) } 1; @@ -286,16 +223,16 @@ SQL::Abstract::Test - Helper function for testing SQL::Abstract is_same_sql_bind is_same_sql is_same_bind eq_sql_bind eq_sql eq_bind /]; - + my ($sql, @bind) = SQL::Abstract->new->select(%args); - is_same_sql_bind($given_sql, \@given_bind, + is_same_sql_bind($given_sql, \@given_bind, $expected_sql, \@expected_bind, $test_msg); is_same_sql($given_sql, $expected_sql, $test_msg); is_same_bind(\@given_bind, \@expected_bind, $test_msg); - my $is_same = eq_sql_bind($given_sql, \@given_bind, + my $is_same = eq_sql_bind($given_sql, \@given_bind, $expected_sql, \@expected_bind); my $sql_same = eq_sql($given_sql, $expected_sql); @@ -313,16 +250,20 @@ ignoring differences in spaces or in levels of parentheses. Therefore the tests will pass as long as the semantics is preserved, even if the surface syntax has changed. -B : this is only a half-cooked semantic equivalence; -parsing is simple-minded, and comparison of SQL abstract syntax trees -ignores commutativity or associativity of AND/OR operators, Morgan -laws, etc. +B : the semantic equivalence handling is pretty limited. +A lot of effort goes into distinguishing significant from +non-significant parenthesis, including AND/OR operator associativity. +Currently this module does not support commutativity and more +intelligent transformations like Morgan laws, etc. + +For a good overview of what this test framework is capable of refer +to C =head1 FUNCTIONS =head2 is_same_sql_bind - is_same_sql_bind($given_sql, \@given_bind, + is_same_sql_bind($given_sql, \@given_bind, $expected_sql, \@expected_bind, $test_msg); Compares given and expected pairs of C<($sql, \@bind)>, and calls @@ -353,7 +294,7 @@ to be imported. =head2 eq_sql_bind - my $is_same = eq_sql_bind($given_sql, \@given_bind, + my $is_same = eq_sql_bind($given_sql, \@given_bind, $expected_sql, \@expected_bind); Compares given and expected pairs of C<($sql, \@bind)>. Similar to @@ -385,6 +326,12 @@ 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 while testing C vs C. +Defaults to false; + =head2 $sql_differ When L returns false, the global variable @@ -402,9 +349,11 @@ Laurent Dami, Elaurent.dami AT etat geneve chE Norbert Buchmuller +Peter Rabbitson + =head1 COPYRIGHT AND LICENSE Copyright 2008 by Laurent Dami. This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself.