From: Laurent Dami Date: Sun, 26 Oct 2008 21:38:43 +0000 (+0000) Subject: moved internal test module into published SQL/Abstract/Test, so that clients of SQLA... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c461c25c909bf7be7f4562f564a82af90b6fb71a;p=scpubgit%2FQ-Branch.git moved internal test module into published SQL/Abstract/Test, so that clients of SQLA can take advantage of it for writing their own tests. --- diff --git a/MANIFEST b/MANIFEST index d44f80c..5ca4d1a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,6 +1,7 @@ Changes INSTALL lib/SQL/Abstract.pm +lib/SQL/Abstract/Test.pm Makefile.PL MANIFEST This list of files t/00new.t @@ -10,4 +11,4 @@ t/03values.t t/06order_by.t t/07subqueries.t t/08special_ops.t -t/TestSqlAbstract.pm + diff --git a/lib/SQL/Abstract/Test.pm b/lib/SQL/Abstract/Test.pm new file mode 100644 index 0000000..e4b4d22 --- /dev/null +++ b/lib/SQL/Abstract/Test.pm @@ -0,0 +1,240 @@ +package SQL::Abstract::Test; # see doc at end of file + +use strict; +use warnings; +use Test::More; +use base 'Exporter'; +use Data::Dumper; +use Carp; + +our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind + $case_sensitive $sql_differ/; + +our $case_sensitive = 0; +our $sql_differ; # keeps track of differing portion between SQLs + +sub is_same_sql_bind { + my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; + + # compare + my $tree1 = parse($sql1); + my $tree2 = parse($sql2); + my $same_sql = eq_sql($tree1, $tree2); + my $same_bind = eq_bind($bind_ref1, $bind_ref2); + + # call Test::More::ok + ok($same_sql && $same_bind, $msg); + + # add debugging info + if (!$same_sql) { + diag "SQL expressions differ\n" + ." got: $sql1\n" + ."expected: $sql2\n" + ."differing in :\n$sql_differ\n"; + ; + } + if (!$same_bind) { + diag "BIND values differ\n" + ." got: " . Dumper($bind_ref1) + ."expected: " . Dumper($bind_ref2) + ; + } +} + + +sub eq_bind { + my ($bind_ref1, $bind_ref2) = @_; + return stringify_bind($bind_ref1) eq stringify_bind($bind_ref2); +} + +sub stringify_bind { + my $bind_ref = shift || []; + + # some bind values can be arrayrefs (see L), + # so stringify them. + my @strings = map {ref $_ ? join('=>', @$_) : ($_ || '')} @$bind_ref; + + # join all values into a single string + return join "///", @strings; +} + +sub eq_sql { + my ($left, $right) = @_; + + # ignore top-level parentheses + while ($left->[0] eq 'PAREN') {$left = $left->[1] } + while ($right->[0] eq 'PAREN') {$right = $right->[1]} + + # 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; + } + # 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 + my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s]; + + my $tree = _recurse_parse($tokens); + return $tree; +} + +sub _recurse_parse { + my $tokens = shift; + + my $left; + while (1) { # left-associative parsing + + my $lookahead = $tokens->[0]; + return $left if !defined($lookahead) || $lookahead eq ')'; + + my $token = shift @$tokens; + + # 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]; + } + # AND/OR + elsif ($token eq 'AND' || $token eq 'OR') { + my $right = _recurse_parse($tokens); + $left = [$token => [$left, $right]]; + } + # leaf expression + else { + $left = $left ? [CONCAT => [$left, [EXPR => $token]]] + : [EXPR => $token]; + } + } +} + + + +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]}->(); +} + + +1; + + +__END__ + +=head1 NAME + +SQL::Abstract::Test - Helper function for testing SQL::Abstract + +=head1 SYNOPSIS + + use SQL::Abstract; + use Test::More; + use SQL::Abstract::Test qw/is_same_sql_bind/; + + my ($sql, @bind) = SQL::Abstract->new->select(%args); + is_same_sql_bind($given_sql, \@given_bind, + $expected_sql, \@expected_bind, $test_msg); + +=head1 DESCRIPTION + +This module is only intended for authors of tests on +L and related modules; +it exports functions for comparing two SQL statements +and their bound values. + +The SQL comparison is performed on I, +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. + +=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. + +=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. + +=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). + +=head1 GLOBAL VARIABLES + +=head2 case_sensitive + +If true, SQL comparisons will be case-sensitive. 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. + +=head1 AUTHOR + +Laurent Dami, Elaurent.dami AT etat geneve chE + +=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. diff --git a/t/00new.t b/t/00new.t index 989a0b2..ee83650 100644 --- a/t/00new.t +++ b/t/00new.t @@ -4,10 +4,7 @@ use strict; use warnings; use Test::More; -use FindBin; -use lib "$FindBin::Bin"; -use TestSqlAbstract; - +use SQL::Abstract::Test qw/is_same_sql_bind/; plan tests => 15; diff --git a/t/01generate.t b/t/01generate.t index 9fbae62..2362e6c 100644 --- a/t/01generate.t +++ b/t/01generate.t @@ -4,10 +4,7 @@ use strict; use warnings; use Test::More; -use FindBin; -use lib "$FindBin::Bin"; -use TestSqlAbstract; - +use SQL::Abstract::Test qw/is_same_sql_bind/; plan tests => 64; use SQL::Abstract; diff --git a/t/02where.t b/t/02where.t index b279651..3e9e649 100644 --- a/t/02where.t +++ b/t/02where.t @@ -5,10 +5,7 @@ use warnings; use Test::More; use Test::Exception; -use FindBin; -use lib "$FindBin::Bin"; -use TestSqlAbstract; - +use SQL::Abstract::Test qw/is_same_sql_bind/; plan tests => 15; use SQL::Abstract; diff --git a/t/03values.t b/t/03values.t index f5e4ffc..9cde7cd 100644 --- a/t/03values.t +++ b/t/03values.t @@ -4,10 +4,7 @@ use strict; use warnings; use Test::More; -use FindBin; -use lib "$FindBin::Bin"; -use TestSqlAbstract; - +use SQL::Abstract::Test qw/is_same_sql_bind/; plan tests => 5; use SQL::Abstract; diff --git a/t/06order_by.t b/t/06order_by.t index a8fc1c7..08477ec 100644 --- a/t/06order_by.t +++ b/t/06order_by.t @@ -6,10 +6,7 @@ use Test::More; use SQL::Abstract; -use FindBin; -use lib "$FindBin::Bin"; -use TestSqlAbstract; - +use SQL::Abstract::Test qw/is_same_sql_bind/; my @cases = ( { diff --git a/t/07subqueries.t b/t/07subqueries.t index b3840d5..c86314f 100644 --- a/t/07subqueries.t +++ b/t/07subqueries.t @@ -4,10 +4,7 @@ use strict; use warnings; use Test::More; -use FindBin; -use lib "$FindBin::Bin"; -use TestSqlAbstract; - +use SQL::Abstract::Test qw/is_same_sql_bind/; plan tests => 5; use SQL::Abstract; diff --git a/t/08special_ops.t b/t/08special_ops.t index 5bc5996..bbccd14 100644 --- a/t/08special_ops.t +++ b/t/08special_ops.t @@ -4,10 +4,7 @@ use strict; use warnings; use Test::More; -use FindBin; -use lib "$FindBin::Bin"; -use TestSqlAbstract; - +use SQL::Abstract::Test qw/is_same_sql_bind/; plan tests => 2; use SQL::Abstract; diff --git a/t/TestSqlAbstract.pm b/t/TestSqlAbstract.pm deleted file mode 100644 index ba8a100..0000000 --- a/t/TestSqlAbstract.pm +++ /dev/null @@ -1,137 +0,0 @@ -package TestSqlAbstract; - -# compares two SQL expressions on their abstract syntax, -# ignoring differences in levels of parentheses. - -use strict; -use warnings; -use Test::More; -use base 'Exporter'; -use Data::Dumper; - -our @EXPORT = qw/is_same_sql_bind/; - - -my $last_differ; - -sub is_same_sql_bind { - my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; - - my $tree1 = parse($sql1); - my $tree2 = parse($sql2); - my $same_sql = eq_tree($tree1, $tree2); - my $same_bind = stringify_bind($bind_ref1) eq stringify_bind($bind_ref2); - ok($same_sql && $same_bind, $msg); - if (!$same_sql) { - diag "SQL expressions differ\n" - ." got: $sql1\n" - ."expected: $sql2\n" - ."differing in :\n$last_differ\n"; - ; - } - if (!$same_bind) { - diag "BIND values differ\n" - ." got: " . Dumper($bind_ref1) - ."expected: " . Dumper($bind_ref2) - ; - } -} - -sub stringify_bind { - my $bind_ref = shift || []; - return join "///", map {ref $_ ? join('=>', @$_) : ($_ || '')} - @$bind_ref; -} - - - -sub eq_tree { - my ($left, $right) = @_; - - # ignore top-level parentheses - while ($left->[0] eq 'PAREN') {$left = $left->[1] } - while ($right->[0] eq 'PAREN') {$right = $right->[1]} - - if ($left->[0] ne $right->[0]) { # if operators are different - $last_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", - unparse($left), - unparse($right); - return 0; - } - else { # else compare operands - if ($left->[0] eq 'EXPR' ) { - if ($left->[1] ne $right->[1]) { - $last_differ = "[$left->[1]] != [$right->[1]]\n"; - return 0; - } - else { - return 1; - } - } - else { - my $eq_left = eq_tree($left->[1][0], $right->[1][0]); - my $eq_right = eq_tree($left->[1][1], $right->[1][1]); - return $eq_left && $eq_right; - } - } -} - - -my @tokens; - -sub parse { - my $s = shift; - - # tokenize string - @tokens = grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s; - - my $tree = _recurse_parse(); - return $tree; -} - -sub _recurse_parse { - - my $left; - while (1) { - - my $lookahead = $tokens[0]; - return $left if !defined($lookahead) || $lookahead eq ')'; - - my $token = shift @tokens; - - if ($token eq '(') { - my $right = _recurse_parse(); - $token = shift @tokens - or die "missing ')'"; - $token eq ')' - or die "unexpected token : $token"; - $left = $left ? [CONCAT => [$left, [PAREN => $right]]] - : [PAREN => $right]; - } - elsif ($token eq 'AND' || $token eq 'OR') { - my $right = _recurse_parse(); - $left = [$token => [$left, $right]]; - } - else { - $left = $left ? [CONCAT => [$left, [EXPR => $token]]] - : [EXPR => $token]; - } - } -} - - - -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]}->(); -} - - -1;