X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FQ-Branch.git;a=blobdiff_plain;f=lib%2FSQL%2FAbstract%2FTest.pm;h=e163f2c5987a0758e96bce06276e752b45f96d83;hp=d55f3a859f2df7d876706eab07a39aedf585d4f5;hb=cf5b7ab163f8ac123ebc9bb1156e79646cd5bd2f;hpb=5aad8cf3d200d1538a5fad5b01895e1ccd3da80a diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm index d55f3a8..e163f2c 100644 --- a/lib/SQL/Abstract/Test.pm +++ b/lib/SQL/Abstract/Test.pm @@ -2,151 +2,289 @@ package SQL::Abstract::Test; # see doc at end of file use strict; use warnings; -use base qw/Test::Builder::Module Exporter/; -use Data::Dumper; -use Carp; +use base qw(Test::Builder::Module Exporter); +use Test::Builder; +use Test::Deep (); +use SQL::Abstract::Tree; + +{ + my $class; + if ($class = $ENV{SQL_ABSTRACT_TEST_AGAINST}) { + my $mod = join('/', split '::', $class).".pm"; + require $mod; + eval qq{sub SQL::Abstract () { "\Q${class}\E" }; 1} + or die "Failed to create const sub for ${class}: $@"; + } + if ($ENV{SQL_ABSTRACT_TEST_EXPAND_STABILITY}) { + $class ||= do { require SQL::Abstract; 'SQL::Abstract' }; + my $orig = $class->can('expand_expr'); + require Data::Dumper::Concise; + my $wrapped = sub { + my ($self, @args) = @_; + my $e1 = $self->$orig(@args); + return $e1 if our $Stab_Check_Rec; + local $Stab_Check_Rec = 1; + my $e2 = $self->$orig($e1); + my ($d1, $d2) = map Data::Dumper::Concise::Dumper($_), $e1, $e2; + (our $tb)->is_eq( + $d2, $d1, + 'expand_expr stability ok' + ) or do { + require Path::Tiny; + Path::Tiny->new('e1')->spew($d1); + Path::Tiny->new('e2')->spew($d2); + system('diff -u e1 e2 1>&2'); + die "Differences between e1 and e2, bailing out"; + }; + return $e1; + }; + no strict 'refs'; no warnings 'redefine'; + *{"${class}::expand_expr"} = $wrapped; + } +} -our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind - $case_sensitive $sql_differ/; +our @EXPORT_OK = qw( + is_same_sql_bind is_same_sql is_same_bind + eq_sql_bind eq_sql eq_bind dumper diag_where + $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; +sub _unpack_arrayrefref { + + my @args; + for (1,2) { + my $chunk = shift @_; + + if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') { + my ($sql, @bind) = @$$chunk; + push @args, ($sql, \@bind); + } + else { + push @args, $chunk, shift @_; + } + + } + + # maybe $msg and ... stuff + push @args, @_; + + @args; +} + sub is_same_sql_bind { - my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; + my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref; # compare - my $tree1 = parse($sql1); - my $tree2 = parse($sql2); - my $same_sql = eq_sql($tree1, $tree2); + my $same_sql = eq_sql($sql1, $sql2); my $same_bind = eq_bind($bind_ref1, $bind_ref2); - # call Test::More::ok - $tb->ok($same_sql && $same_bind, $msg); + # call Test::Builder::ok + my $ret = $tb->ok($same_sql && $same_bind, $msg); # add debugging info if (!$same_sql) { - $tb->diag("SQL expressions differ\n" - ." got: $sql1\n" - ."expected: $sql2\n" - ."differing in :\n$sql_differ\n" - ); + _sql_differ_diag($sql1, $sql2); } if (!$same_bind) { - $tb->diag("BIND values differ\n" - ." got: " . Dumper($bind_ref1) - ."expected: " . Dumper($bind_ref2) - ); + _bind_differ_diag($bind_ref1, $bind_ref2); } + + # pass ok() result further + return $ret; } +sub is_same_sql { + my ($sql1, $sql2, $msg) = @_; -sub eq_bind { - my ($bind_ref1, $bind_ref2) = @_; - return stringify_bind($bind_ref1) eq stringify_bind($bind_ref2); -} + # compare + my $same_sql = eq_sql($sql1, $sql2); -sub stringify_bind { - my $bind_ref = shift || []; + # call Test::Builder::ok + my $ret = $tb->ok($same_sql, $msg); - # some bind values can be arrayrefs (see L), - # so stringify them. - my @strings = map {ref $_ eq 'ARRAY' ? join('=>', @$_) : ($_ || '')} - @$bind_ref; + # add debugging info + if (!$same_sql) { + _sql_differ_diag($sql1, $sql2); + } - # join all values into a single string - return join "///", @strings; + # pass ok() result further + return $ret; } -sub eq_sql { - my ($left, $right) = @_; +sub is_same_bind { + my ($bind_ref1, $bind_ref2, $msg) = @_; + + # compare + my $same_bind = eq_bind($bind_ref1, $bind_ref2); - # ignore top-level parentheses - while ($left->[0] eq 'PAREN') {$left = $left->[1] } - while ($right->[0] eq 'PAREN') {$right = $right->[1]} + # call Test::Builder::ok + my $ret = $tb->ok($same_bind, $msg); - # 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); - return 0; + # add debugging info + if (!$same_bind) { + _bind_differ_diag($bind_ref1, $bind_ref2); } - # 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 - } + + # pass ok() result further + return $ret; +} + +sub dumper { + # FIXME + # if we save the instance, we will end up with $VARx references + # no time to figure out how to avoid this (Deepcopy is *not* an option) + require Data::Dumper; + Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0) + ->Values([@_])->Dump; +} + +sub diag_where{ + $tb->diag("Search term:\n" . &dumper); +} + +sub _sql_differ_diag { + my $sql1 = shift || ''; + my $sql2 = shift || ''; + + if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) { + my $sqlat = SQL::Abstract::Tree->new(profile => $profile); + $_ = $sqlat->format($_) for ($sql1, $sql2); } + + $tb->${\($tb->in_todo ? 'note' : 'diag')} ( + "SQL expressions differ\n" + ." got: $sql1\n" + ."want: $sql2\n" + ."\nmismatch around\n$sql_differ\n" + ); } +sub _bind_differ_diag { + my ($bind_ref1, $bind_ref2) = @_; -sub parse { - my $s = shift; + $tb->${\($tb->in_todo ? 'note' : 'diag')} ( + "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 }) + ); +} - # tokenize string - my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s]; +sub eq_sql_bind { + my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref; - my $tree = _recurse_parse($tokens); - return $tree; + return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); } -sub _recurse_parse { - my $tokens = shift; - my $left; - while (1) { # left-associative parsing +sub eq_bind { goto &Test::Deep::eq_deeply }; - my $lookahead = $tokens->[0]; - return $left if !defined($lookahead) || $lookahead eq ')'; +sub eq_sql { + my ($sql1, $sql2) = @_; - my $token = shift @$tokens; + # parse + my $tree1 = $sqlat->parse($sql1); + my $tree2 = $sqlat->parse($sql2); - # nested expression in () - if ($token eq '(') { - my $right = _recurse_parse($tokens); - $token = shift @$tokens or croak "missing ')'"; - $token eq ')' or croak "unexpected token : $token"; - $left = $left ? [CONCAT => [$left, [PAREN => $right]]] - : [PAREN => $right]; + undef $sql_differ; + return 1 if _eq_sql($tree1, $tree2); +} + +sub _eq_sql { + my ($left, $right) = @_; + + # 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 ("[%s] != [%s]\nleft: %s\nright: %s\n", map + { ref $_ ? $sqlat->unparse($_) : $_ } + ($left->[0], $right->[0], $left, $right) + ); + return 0; + } + + # 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; + } } - # AND/OR - elsif ($token eq 'AND' || $token eq 'OR') { - my $right = _recurse_parse($tokens); - $left = [$token => [$left, $right]]; + return 1; + } + + # both are ops + else { + + # unroll parenthesis if possible/allowed + unless ($parenthesis_significant) { + $sqlat->_parenthesis_unroll($_) for $left, $right; } - # leaf expression - else { - $left = $left ? [CONCAT => [$left, [EXPR => $token]]] - : [EXPR => $token]; + + # unroll ASC order by's + unless ($order_by_asc_significant) { + $sqlat->_strip_asc_from_order_by($_) for $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; + } + # 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; + } -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]}->(); + # 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(@_) } 1; @@ -160,12 +298,25 @@ SQL::Abstract::Test - Helper function for testing SQL::Abstract use SQL::Abstract; use Test::More; - use SQL::Abstract::Test import => ['is_same_sql_bind']; - + use SQL::Abstract::Test import => [qw/ + 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, + $expected_sql, \@expected_bind); + + my $sql_same = eq_sql($given_sql, $expected_sql); + my $bind_same = eq_bind(\@given_bind, \@expected_bind); + =head1 DESCRIPTION This module is only intended for authors of tests on @@ -178,64 +329,145 @@ 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 L, etc. + +For a good overview of what this test framework is currently capable of refer +to C =head1 FUNCTIONS =head2 is_same_sql_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 -L on the result, with C<$test_msg> as message. If the -test fails, a detailed diagnostic is printed. For clients which use -L, this is the only function that needs to be -imported. + is_same_sql_bind( + $given_sql, \@given_bind, + $expected_sql, \@expected_bind, + $test_msg + ); + + is_same_sql_bind( + \[$given_sql, @given_bind], + \[$expected_sql, @expected_bind], + $test_msg + ); + + is_same_sql_bind( + $dbic_rs->as_query + $expected_sql, \@expected_bind, + $test_msg + ); + +Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_> +as shown in the examples above and passing the arguments to L and +L. Calls L with the combined result, with +C<$test_msg> as message. +If the test fails, a detailed diagnostic is printed. + +=head2 is_same_sql + + is_same_sql( + $given_sql, + $expected_sql, + $test_msg + ); + +Compares given and expected SQL statements via L, and calls +L on the result, with C<$test_msg> as message. +If the test fails, a detailed diagnostic is printed. + +=head2 is_same_bind + + is_same_bind( + \@given_bind, + \@expected_bind, + $test_msg + ); + +Compares given and expected bind values via L, and calls +L on the result, with C<$test_msg> as message. +If the test fails, a detailed diagnostic is printed. + +=head2 eq_sql_bind + + my $is_same = eq_sql_bind( + $given_sql, \@given_bind, + $expected_sql, \@expected_bind, + ); + + my $is_same = eq_sql_bind( + \[$given_sql, @given_bind], + \[$expected_sql, @expected_bind], + ); + + my $is_same = eq_sql_bind( + $dbic_rs->as_query + $expected_sql, \@expected_bind, + ); + +Unpacks C<@_> depending on the given arguments and calls L and +L, returning their combined result. =head2 eq_sql my $is_same = eq_sql($given_sql, $expected_sql); -Compares the abstract syntax of two SQL statements. If the result is -false, global variable L will contain the SQL portion -where a difference was encountered; this is useful for printing diagnostics. +Compares the abstract syntax of two SQL statements. Similar to L, +but it just returns a boolean value and does not print diagnostics or talk to +L. If the result is false, the global variable L +will contain the SQL portion where a difference was encountered; this is useful +for printing diagnostics. =head2 eq_bind my $is_same = eq_sql(\@given_bind, \@expected_bind); -Compares two lists of bind values, taking into account -the fact that some of the values may be -arrayrefs (see L). +Compares two lists of bind values, taking into account the fact that some of +the values may be arrayrefs (see L). Similar to +L, but it just returns a boolean value and does not print +diagnostics or talk to L. =head1 GLOBAL VARIABLES -=head2 case_sensitive +=head2 $case_sensitive If true, SQL comparisons will be case-sensitive. Default is false; -=head2 sql_differ +=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 $order_by_asc_significant + +If true SQL comparison will consider C and +C to be different. Default is false; + +=head2 $sql_differ When L returns false, the global variable C<$sql_differ> contains the SQL portion where a difference was encountered. - =head1 SEE ALSO -L, L. +L, L, L. + +=head1 AUTHORS + +Laurent Dami -=head1 AUTHOR +Norbert Buchmuller -Laurent Dami, Elaurent.dami AT etat geneve chE +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.