1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw(Test::Builder::Module Exporter);
9 use SQL::Abstract::Tree;
12 is_same_sql_bind is_same_sql is_same_bind
13 eq_sql_bind eq_sql eq_bind dumper diag_where
14 $case_sensitive $sql_differ
17 my $sqlat = SQL::Abstract::Tree->new;
19 our $case_sensitive = 0;
20 our $parenthesis_significant = 0;
21 our $order_by_asc_significant = 0;
23 our $sql_differ; # keeps track of differing portion between SQLs
24 our $tb = __PACKAGE__->builder;
26 sub is_same_sql_bind {
27 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
30 my $same_sql = eq_sql($sql1, $sql2);
31 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
33 # call Test::Builder::ok
34 my $ret = $tb->ok($same_sql && $same_bind, $msg);
38 _sql_differ_diag($sql1, $sql2);
41 _bind_differ_diag($bind_ref1, $bind_ref2);
44 # pass ok() result further
49 my ($sql1, $sql2, $msg) = @_;
52 my $same_sql = eq_sql($sql1, $sql2);
54 # call Test::Builder::ok
55 my $ret = $tb->ok($same_sql, $msg);
59 _sql_differ_diag($sql1, $sql2);
62 # pass ok() result further
67 my ($bind_ref1, $bind_ref2, $msg) = @_;
70 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
72 # call Test::Builder::ok
73 my $ret = $tb->ok($same_bind, $msg);
77 _bind_differ_diag($bind_ref1, $bind_ref2);
80 # pass ok() result further
85 Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)->Values([@_])->Dump;
89 $tb->diag( "Search term:\n" . &dumper );
92 sub _sql_differ_diag {
93 my ($sql1, $sql2) = @_;
95 $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
96 "SQL expressions differ\n"
99 ."differing in :\n$sql_differ\n"
103 sub _bind_differ_diag {
104 my ($bind_ref1, $bind_ref2) = @_;
106 $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
107 "BIND values differ\n"
108 ." got: " . dumper($bind_ref1)
109 ."expected: " . dumper($bind_ref2)
114 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
116 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
120 sub eq_bind { goto &Test::Deep::eq_deeply };
123 my ($sql1, $sql2) = @_;
126 my $tree1 = $sqlat->parse($sql1);
127 my $tree2 = $sqlat->parse($sql2);
130 return 1 if _eq_sql($tree1, $tree2);
134 my ($left, $right) = @_;
136 # one is defined the other not
137 if ( (defined $left) xor (defined $right) ) {
138 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
142 # one is undefined, then so is the other
143 elsif (not defined $left) {
148 elsif (@$left == 0 and @$right == 0) {
153 if (@$left == 0 or @$right == 0) {
154 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
158 # one is a list, the other is an op with a list
159 elsif (ref $left->[0] xor ref $right->[0]) {
160 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
161 { ref $_ ? $sqlat->unparse ($_) : $_ }
162 ($left->[0], $right->[0], $left, $right)
168 elsif (ref $left->[0]) {
169 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
170 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
171 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
173 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
174 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
185 # unroll parenthesis if possible/allowed
186 unless ( $parenthesis_significant ) {
187 $sqlat->_parenthesis_unroll($_) for $left, $right;
190 # unroll ASC order by's
191 unless ($order_by_asc_significant) {
192 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
195 if ( $left->[0] ne $right->[0] ) {
196 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
197 $sqlat->unparse($left),
198 $sqlat->unparse($right)
203 # literals have a different arg-sig
204 elsif ($left->[0] eq '-LITERAL') {
205 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
206 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
207 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
208 $sql_differ = "[$l] != [$r]\n" if not $eq;
212 # if operators are identical, compare operands
214 my $eq = _eq_sql($left->[1], $right->[1]);
215 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
221 sub parse { $sqlat->parse(@_) }
229 SQL::Abstract::Test - Helper function for testing SQL::Abstract
235 use SQL::Abstract::Test import => [qw/
236 is_same_sql_bind is_same_sql is_same_bind
237 eq_sql_bind eq_sql eq_bind
240 my ($sql, @bind) = SQL::Abstract->new->select(%args);
242 is_same_sql_bind($given_sql, \@given_bind,
243 $expected_sql, \@expected_bind, $test_msg);
245 is_same_sql($given_sql, $expected_sql, $test_msg);
246 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
248 my $is_same = eq_sql_bind($given_sql, \@given_bind,
249 $expected_sql, \@expected_bind);
251 my $sql_same = eq_sql($given_sql, $expected_sql);
252 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
256 This module is only intended for authors of tests on
257 L<SQL::Abstract|SQL::Abstract> and related modules;
258 it exports functions for comparing two SQL statements
259 and their bound values.
261 The SQL comparison is performed on I<abstract syntax>,
262 ignoring differences in spaces or in levels of parentheses.
263 Therefore the tests will pass as long as the semantics
264 is preserved, even if the surface syntax has changed.
266 B<Disclaimer> : the semantic equivalence handling is pretty limited.
267 A lot of effort goes into distinguishing significant from
268 non-significant parenthesis, including AND/OR operator associativity.
269 Currently this module does not support commutativity and more
270 intelligent transformations like Morgan laws, etc.
272 For a good overview of what this test framework is capable of refer
277 =head2 is_same_sql_bind
279 is_same_sql_bind($given_sql, \@given_bind,
280 $expected_sql, \@expected_bind, $test_msg);
282 Compares given and expected pairs of C<($sql, \@bind)>, and calls
283 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
284 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
285 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
286 L</is_same_bind>) that needs to be imported.
290 is_same_sql($given_sql, $expected_sql, $test_msg);
292 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
293 the result, with C<$test_msg> as message. If the test fails, a detailed
294 diagnostic is printed. For clients which use L<Test::More>, this is the one of
295 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
296 that needs to be imported.
300 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
302 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
303 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
304 is printed. For clients which use L<Test::More>, this is the one of the three
305 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
310 my $is_same = eq_sql_bind($given_sql, \@given_bind,
311 $expected_sql, \@expected_bind);
313 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
314 L</is_same_sql_bind>, but it just returns a boolean value and does not print
315 diagnostics or talk to L<Test::Builder>.
319 my $is_same = eq_sql($given_sql, $expected_sql);
321 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
322 but it just returns a boolean value and does not print diagnostics or talk to
323 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
324 will contain the SQL portion where a difference was encountered; this is useful
325 for printing diagnostics.
329 my $is_same = eq_sql(\@given_bind, \@expected_bind);
331 Compares two lists of bind values, taking into account the fact that some of
332 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
333 L</is_same_bind>, but it just returns a boolean value and does not print
334 diagnostics or talk to L<Test::Builder>.
336 =head1 GLOBAL VARIABLES
338 =head2 $case_sensitive
340 If true, SQL comparisons will be case-sensitive. Default is false;
342 =head2 $parenthesis_significant
344 If true, SQL comparison will preserve and report difference in nested
345 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
348 =head2 $order_by_asc_significant
350 If true SQL comparison will consider C<ORDER BY foo ASC> and
351 C<ORDER BY foo> to be different. Default is false;
355 When L</eq_sql> returns false, the global variable
356 C<$sql_differ> contains the SQL portion
357 where a difference was encountered.
362 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
366 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
368 Norbert Buchmuller <norbi@nix.hu>
370 Peter Rabbitson <ribasushi@cpan.org>
372 =head1 COPYRIGHT AND LICENSE
374 Copyright 2008 by Laurent Dami.
376 This library is free software; you can redistribute it and/or modify
377 it under the same terms as Perl itself.