1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw/Test::Builder::Module Exporter/;
8 use SQL::Abstract::Tree;
10 our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
11 &eq_sql_bind &eq_sql &eq_bind
12 $case_sensitive $sql_differ/;
14 my $sqlat = SQL::Abstract::Tree->new;
16 our $case_sensitive = 0;
17 our $parenthesis_significant = 0;
18 our $sql_differ; # keeps track of differing portion between SQLs
19 our $tb = __PACKAGE__->builder;
21 sub is_same_sql_bind {
22 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
25 my $same_sql = eq_sql($sql1, $sql2);
26 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
28 # call Test::Builder::ok
29 my $ret = $tb->ok($same_sql && $same_bind, $msg);
33 _sql_differ_diag($sql1, $sql2);
36 _bind_differ_diag($bind_ref1, $bind_ref2);
39 # pass ok() result further
44 my ($sql1, $sql2, $msg) = @_;
47 my $same_sql = eq_sql($sql1, $sql2);
49 # call Test::Builder::ok
50 my $ret = $tb->ok($same_sql, $msg);
54 _sql_differ_diag($sql1, $sql2);
57 # pass ok() result further
62 my ($bind_ref1, $bind_ref2, $msg) = @_;
65 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
67 # call Test::Builder::ok
68 my $ret = $tb->ok($same_bind, $msg);
72 _bind_differ_diag($bind_ref1, $bind_ref2);
75 # pass ok() result further
79 sub _sql_differ_diag {
80 my ($sql1, $sql2) = @_;
82 $tb->diag("SQL expressions differ\n"
85 ."differing in :\n$sql_differ\n"
89 sub _bind_differ_diag {
90 my ($bind_ref1, $bind_ref2) = @_;
92 $tb->diag("BIND values differ\n"
93 ." got: " . Dumper($bind_ref1)
94 ."expected: " . Dumper($bind_ref2)
99 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
101 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
106 my ($bind_ref1, $bind_ref2) = @_;
108 local $Data::Dumper::Useqq = 1;
109 local $Data::Dumper::Sortkeys = 1;
111 return Dumper($bind_ref1) eq Dumper($bind_ref2);
115 my ($sql1, $sql2) = @_;
118 my $tree1 = $sqlat->parse($sql1);
119 my $tree2 = $sqlat->parse($sql2);
121 return 1 if _eq_sql($tree1, $tree2);
125 my ($left, $right) = @_;
127 # one is defined the other not
128 if ( (defined $left) xor (defined $right) ) {
131 # one is undefined, then so is the other
132 elsif (not defined $left) {
135 # different amount of elements
136 elsif (@$left != @$right) {
137 $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
140 # one is empty - so is the other
141 elsif (@$left == 0) {
144 # one is a list, the other is an op with a list
145 elsif (ref $left->[0] xor ref $right->[0]) {
146 $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
149 # one is a list, so is the other
150 elsif (ref $left->[0]) {
151 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
152 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
156 # both are an op-list combo
159 # unroll parenthesis if possible/allowed
160 $parenthesis_significant || $sqlat->_parenthesis_unroll($_) for $left, $right;
162 # if operators are different
163 if ( $left->[0] ne $right->[0] ) {
164 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
165 $sqlat->unparse($left),
166 $sqlat->unparse($right);
169 # elsif operators are identical, compare operands
171 if ($left->[0] eq 'LITERAL' ) { # unary
172 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
173 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
174 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
175 $sql_differ = "[$l] != [$r]\n" if not $eq;
179 my $eq = _eq_sql($left->[1], $right->[1]);
180 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
187 sub parse { $sqlat->parse(@_) }
195 SQL::Abstract::Test - Helper function for testing SQL::Abstract
201 use SQL::Abstract::Test import => [qw/
202 is_same_sql_bind is_same_sql is_same_bind
203 eq_sql_bind eq_sql eq_bind
206 my ($sql, @bind) = SQL::Abstract->new->select(%args);
208 is_same_sql_bind($given_sql, \@given_bind,
209 $expected_sql, \@expected_bind, $test_msg);
211 is_same_sql($given_sql, $expected_sql, $test_msg);
212 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
214 my $is_same = eq_sql_bind($given_sql, \@given_bind,
215 $expected_sql, \@expected_bind);
217 my $sql_same = eq_sql($given_sql, $expected_sql);
218 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
222 This module is only intended for authors of tests on
223 L<SQL::Abstract|SQL::Abstract> and related modules;
224 it exports functions for comparing two SQL statements
225 and their bound values.
227 The SQL comparison is performed on I<abstract syntax>,
228 ignoring differences in spaces or in levels of parentheses.
229 Therefore the tests will pass as long as the semantics
230 is preserved, even if the surface syntax has changed.
232 B<Disclaimer> : the semantic equivalence handling is pretty limited.
233 A lot of effort goes into distinguishing significant from
234 non-significant parenthesis, including AND/OR operator associativity.
235 Currently this module does not support commutativity and more
236 intelligent transformations like Morgan laws, etc.
238 For a good overview of what this test framework is capable of refer
243 =head2 is_same_sql_bind
245 is_same_sql_bind($given_sql, \@given_bind,
246 $expected_sql, \@expected_bind, $test_msg);
248 Compares given and expected pairs of C<($sql, \@bind)>, and calls
249 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
250 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
251 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
252 L</is_same_bind>) that needs to be imported.
256 is_same_sql($given_sql, $expected_sql, $test_msg);
258 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
259 the result, with C<$test_msg> as message. If the test fails, a detailed
260 diagnostic is printed. For clients which use L<Test::More>, this is the one of
261 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
262 that needs to be imported.
266 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
268 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
269 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
270 is printed. For clients which use L<Test::More>, this is the one of the three
271 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
276 my $is_same = eq_sql_bind($given_sql, \@given_bind,
277 $expected_sql, \@expected_bind);
279 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
280 L</is_same_sql_bind>, but it just returns a boolean value and does not print
281 diagnostics or talk to L<Test::Builder>.
285 my $is_same = eq_sql($given_sql, $expected_sql);
287 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
288 but it just returns a boolean value and does not print diagnostics or talk to
289 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
290 will contain the SQL portion where a difference was encountered; this is useful
291 for printing diagnostics.
295 my $is_same = eq_sql(\@given_bind, \@expected_bind);
297 Compares two lists of bind values, taking into account the fact that some of
298 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
299 L</is_same_bind>, but it just returns a boolean value and does not print
300 diagnostics or talk to L<Test::Builder>.
302 =head1 GLOBAL VARIABLES
304 =head2 $case_sensitive
306 If true, SQL comparisons will be case-sensitive. Default is false;
308 =head2 $parenthesis_significant
310 If true, SQL comparison will preserve and report difference in nested
311 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
315 When L</eq_sql> returns false, the global variable
316 C<$sql_differ> contains the SQL portion
317 where a difference was encountered.
322 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
326 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
328 Norbert Buchmuller <norbi@nix.hu>
330 Peter Rabbitson <ribasushi@cpan.org>
332 =head1 COPYRIGHT AND LICENSE
334 Copyright 2008 by Laurent Dami.
336 This library is free software; you can redistribute it and/or modify
337 it under the same terms as Perl itself.