--- /dev/null
+package SQL::Abstract::Test; # see doc at end of file\r
+\r
+use strict;\r
+use warnings;\r
+use Test::More;\r
+use base 'Exporter';\r
+use Data::Dumper;\r
+use Carp;\r
+\r
+our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind \r
+ $case_sensitive $sql_differ/;\r
+\r
+our $case_sensitive = 0;\r
+our $sql_differ; # keeps track of differing portion between SQLs\r
+\r
+sub is_same_sql_bind {\r
+ my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;\r
+\r
+ # compare\r
+ my $tree1 = parse($sql1);\r
+ my $tree2 = parse($sql2);\r
+ my $same_sql = eq_sql($tree1, $tree2);\r
+ my $same_bind = eq_bind($bind_ref1, $bind_ref2);\r
+\r
+ # call Test::More::ok\r
+ ok($same_sql && $same_bind, $msg);\r
+\r
+ # add debugging info\r
+ if (!$same_sql) {\r
+ diag "SQL expressions differ\n"\r
+ ." got: $sql1\n"\r
+ ."expected: $sql2\n"\r
+ ."differing in :\n$sql_differ\n";\r
+ ;\r
+ }\r
+ if (!$same_bind) {\r
+ diag "BIND values differ\n"\r
+ ." got: " . Dumper($bind_ref1)\r
+ ."expected: " . Dumper($bind_ref2)\r
+ ;\r
+ }\r
+}\r
+\r
+\r
+sub eq_bind {\r
+ my ($bind_ref1, $bind_ref2) = @_;\r
+ return stringify_bind($bind_ref1) eq stringify_bind($bind_ref2);\r
+}\r
+\r
+sub stringify_bind {\r
+ my $bind_ref = shift || [];\r
+\r
+ # some bind values can be arrayrefs (see L<SQL::Abstract/bindtype>),\r
+ # so stringify them.\r
+ my @strings = map {ref $_ ? join('=>', @$_) : ($_ || '')} @$bind_ref;\r
+\r
+ # join all values into a single string\r
+ return join "///", @strings;\r
+}\r
+\r
+sub eq_sql {\r
+ my ($left, $right) = @_;\r
+\r
+ # ignore top-level parentheses \r
+ while ($left->[0] eq 'PAREN') {$left = $left->[1] }\r
+ while ($right->[0] eq 'PAREN') {$right = $right->[1]}\r
+\r
+ # if operators are different\r
+ if ($left->[0] ne $right->[0]) { \r
+ $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",\r
+ unparse($left),\r
+ unparse($right);\r
+ return 0;\r
+ }\r
+ # elsif operators are identical, compare operands\r
+ else { \r
+ if ($left->[0] eq 'EXPR' ) { # unary operator\r
+ (my $l = " $left->[1] " ) =~ s/\s+/ /g;\r
+ (my $r = " $right->[1] ") =~ s/\s+/ /g;\r
+ my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);\r
+ $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;\r
+ return $eq;\r
+ }\r
+ else { # binary operator\r
+ return eq_sql($left->[1][0], $right->[1][0]) # left operand\r
+ && eq_sql($left->[1][1], $right->[1][1]); # right operand\r
+ }\r
+ }\r
+}\r
+\r
+\r
+sub parse {\r
+ my $s = shift;\r
+\r
+ # tokenize string\r
+ my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s];\r
+\r
+ my $tree = _recurse_parse($tokens);\r
+ return $tree;\r
+}\r
+\r
+sub _recurse_parse {\r
+ my $tokens = shift;\r
+\r
+ my $left;\r
+ while (1) { # left-associative parsing\r
+\r
+ my $lookahead = $tokens->[0];\r
+ return $left if !defined($lookahead) || $lookahead eq ')';\r
+\r
+ my $token = shift @$tokens;\r
+\r
+ # nested expression in ()\r
+ if ($token eq '(') {\r
+ my $right = _recurse_parse($tokens);\r
+ $token = shift @$tokens or croak "missing ')'";\r
+ $token eq ')' or croak "unexpected token : $token";\r
+ $left = $left ? [CONCAT => [$left, [PAREN => $right]]]\r
+ : [PAREN => $right];\r
+ }\r
+ # AND/OR\r
+ elsif ($token eq 'AND' || $token eq 'OR') {\r
+ my $right = _recurse_parse($tokens);\r
+ $left = [$token => [$left, $right]];\r
+ }\r
+ # leaf expression\r
+ else {\r
+ $left = $left ? [CONCAT => [$left, [EXPR => $token]]]\r
+ : [EXPR => $token];\r
+ }\r
+ }\r
+}\r
+\r
+\r
+\r
+sub unparse {\r
+ my $tree = shift;\r
+ my $dispatch = {\r
+ EXPR => sub {$tree->[1] },\r
+ PAREN => sub {"(" . unparse($tree->[1]) . ")" },\r
+ CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},\r
+ AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},\r
+ OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},\r
+ };\r
+ $dispatch->{$tree->[0]}->();\r
+}\r
+\r
+\r
+1;\r
+\r
+\r
+__END__\r
+\r
+=head1 NAME\r
+\r
+SQL::Abstract::Test - Helper function for testing SQL::Abstract\r
+\r
+=head1 SYNOPSIS\r
+\r
+ use SQL::Abstract;\r
+ use Test::More;\r
+ use SQL::Abstract::Test qw/is_same_sql_bind/;\r
+ \r
+ my ($sql, @bind) = SQL::Abstract->new->select(%args);\r
+ is_same_sql_bind($given_sql, \@given_bind, \r
+ $expected_sql, \@expected_bind, $test_msg);\r
+\r
+=head1 DESCRIPTION\r
+\r
+This module is only intended for authors of tests on\r
+L<SQL::Abstract|SQL::Abstract> and related modules;\r
+it exports functions for comparing two SQL statements\r
+and their bound values.\r
+\r
+The SQL comparison is performed on I<abstract syntax>,\r
+ignoring differences in spaces or in levels of parentheses.\r
+Therefore the tests will pass as long as the semantics\r
+is preserved, even if the surface syntax has changed.\r
+\r
+B<Disclaimer> : this is only a half-cooked semantic equivalence;\r
+parsing is simple-minded, and comparison of SQL abstract syntax trees\r
+ignores commutativity or associativity of AND/OR operators, Morgan\r
+laws, etc.\r
+\r
+=head1 FUNCTIONS\r
+\r
+=head2 is_same_sql_bind\r
+\r
+ is_same_sql_bind($given_sql, \@given_bind, \r
+ $expected_sql, \@expected_bind, $test_msg);\r
+\r
+Compares given and expected pairs of C<($sql, \@bind)>, and calls\r
+L<Test::More/ok> on the result, with C<$test_msg> as message. If the\r
+test fails, a detailed diagnostic is printed. For clients which use\r
+L<Test::More|Test::More>, this is the only function that needs to be\r
+imported.\r
+\r
+=head2 eq_sql\r
+\r
+ my $is_same = eq_sql($given_sql, $expected_sql);\r
+\r
+Compares the abstract syntax of two SQL statements. If the result is\r
+false, global variable L</sql_differ> will contain the SQL portion\r
+where a difference was encountered; this is useful for printing diagnostics.\r
+\r
+=head2 eq_bind\r
+\r
+ my $is_same = eq_sql(\@given_bind, \@expected_bind);\r
+\r
+Compares two lists of bind values, taking into account\r
+the fact that some of the values may be\r
+arrayrefs (see L<SQL::Abstract/bindtype>).\r
+\r
+=head1 GLOBAL VARIABLES\r
+\r
+=head2 case_sensitive\r
+\r
+If true, SQL comparisons will be case-sensitive. Default is false;\r
+\r
+=head2 sql_differ\r
+\r
+When L</eq_sql> returns false, the global variable\r
+C<$sql_differ> contains the SQL portion\r
+where a difference was encountered.\r
+\r
+\r
+=head1 SEE ALSO\r
+\r
+L<SQL::Abstract>, L<Test::More>.\r
+\r
+=head1 AUTHOR\r
+\r
+Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>\r
+\r
+=head1 COPYRIGHT AND LICENSE\r
+\r
+Copyright 2008 by Laurent Dami.\r
+\r
+This library is free software; you can redistribute it and/or modify\r
+it under the same terms as Perl itself. \r
+++ /dev/null
-package TestSqlAbstract;\r
-\r
-# compares two SQL expressions on their abstract syntax,\r
-# ignoring differences in levels of parentheses.\r
-\r
-use strict;\r
-use warnings;\r
-use Test::More;\r
-use base 'Exporter';\r
-use Data::Dumper;\r
-\r
-our @EXPORT = qw/is_same_sql_bind/;\r
-\r
-\r
-my $last_differ;\r
-\r
-sub is_same_sql_bind {\r
- my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;\r
-\r
- my $tree1 = parse($sql1);\r
- my $tree2 = parse($sql2);\r
- my $same_sql = eq_tree($tree1, $tree2);\r
- my $same_bind = stringify_bind($bind_ref1) eq stringify_bind($bind_ref2);\r
- ok($same_sql && $same_bind, $msg);\r
- if (!$same_sql) {\r
- diag "SQL expressions differ\n"\r
- ." got: $sql1\n"\r
- ."expected: $sql2\n"\r
- ."differing in :\n$last_differ\n";\r
- ;\r
- }\r
- if (!$same_bind) {\r
- diag "BIND values differ\n"\r
- ." got: " . Dumper($bind_ref1)\r
- ."expected: " . Dumper($bind_ref2)\r
- ;\r
- }\r
-}\r
-\r
-sub stringify_bind {\r
- my $bind_ref = shift || [];\r
- return join "///", map {ref $_ ? join('=>', @$_) : ($_ || '')} \r
- @$bind_ref;\r
-}\r
-\r
-\r
-\r
-sub eq_tree {\r
- my ($left, $right) = @_;\r
-\r
- # ignore top-level parentheses \r
- while ($left->[0] eq 'PAREN') {$left = $left->[1] }\r
- while ($right->[0] eq 'PAREN') {$right = $right->[1]}\r
-\r
- if ($left->[0] ne $right->[0]) { # if operators are different\r
- $last_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",\r
- unparse($left),\r
- unparse($right);\r
- return 0;\r
- }\r
- else { # else compare operands\r
- if ($left->[0] eq 'EXPR' ) {\r
- if ($left->[1] ne $right->[1]) {\r
- $last_differ = "[$left->[1]] != [$right->[1]]\n";\r
- return 0;\r
- }\r
- else {\r
- return 1;\r
- }\r
- }\r
- else {\r
- my $eq_left = eq_tree($left->[1][0], $right->[1][0]);\r
- my $eq_right = eq_tree($left->[1][1], $right->[1][1]);\r
- return $eq_left && $eq_right;\r
- }\r
- }\r
-}\r
-\r
-\r
-my @tokens;\r
-\r
-sub parse {\r
- my $s = shift;\r
-\r
- # tokenize string\r
- @tokens = grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s;\r
-\r
- my $tree = _recurse_parse();\r
- return $tree;\r
-}\r
-\r
-sub _recurse_parse {\r
-\r
- my $left;\r
- while (1) {\r
-\r
- my $lookahead = $tokens[0];\r
- return $left if !defined($lookahead) || $lookahead eq ')';\r
-\r
- my $token = shift @tokens;\r
-\r
- if ($token eq '(') {\r
- my $right = _recurse_parse();\r
- $token = shift @tokens \r
- or die "missing ')'";\r
- $token eq ')' \r
- or die "unexpected token : $token";\r
- $left = $left ? [CONCAT => [$left, [PAREN => $right]]]\r
- : [PAREN => $right];\r
- }\r
- elsif ($token eq 'AND' || $token eq 'OR') {\r
- my $right = _recurse_parse();\r
- $left = [$token => [$left, $right]];\r
- }\r
- else {\r
- $left = $left ? [CONCAT => [$left, [EXPR => $token]]]\r
- : [EXPR => $token];\r
- }\r
- }\r
-}\r
-\r
-\r
-\r
-sub unparse {\r
- my $tree = shift;\r
- my $dispatch = {\r
- EXPR => sub {$tree->[1] },\r
- PAREN => sub {"(" . unparse($tree->[1]) . ")" },\r
- CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},\r
- AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},\r
- OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},\r
- };\r
- $dispatch->{$tree->[0]}->();\r
-}\r
-\r
-\r
-1;\r
projects / dbsrgits/SQL-Abstract.git / commitdiff