1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw(Test::Builder::Module Exporter);
8 use SQL::Abstract::Tree;
11 is_same_sql_bind is_same_sql is_same_bind
12 eq_sql_bind eq_sql eq_bind dumper diag_where
13 $case_sensitive $sql_differ
16 my $sqlat = SQL::Abstract::Tree->new;
18 our $case_sensitive = 0;
19 our $parenthesis_significant = 0;
20 our $order_by_asc_significant = 0;
22 our $sql_differ; # keeps track of differing portion between SQLs
23 our $tb = __PACKAGE__->builder;
25 sub _unpack_arrayrefref {
31 if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') {
32 my ($sql, @bind) = @$$chunk;
33 push @args, ($sql, \@bind);
36 push @args, $chunk, shift @_;
41 # maybe $msg and ... stuff
47 sub is_same_sql_bind {
48 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref;
51 my $same_sql = eq_sql($sql1, $sql2);
52 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
54 # call Test::Builder::ok
55 my $ret = $tb->ok($same_sql && $same_bind, $msg);
59 _sql_differ_diag($sql1, $sql2);
62 _bind_differ_diag($bind_ref1, $bind_ref2);
65 # pass ok() result further
70 my ($sql1, $sql2, $msg) = @_;
73 my $same_sql = eq_sql($sql1, $sql2);
75 # call Test::Builder::ok
76 my $ret = $tb->ok($same_sql, $msg);
80 _sql_differ_diag($sql1, $sql2);
83 # pass ok() result further
88 my ($bind_ref1, $bind_ref2, $msg) = @_;
91 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
93 # call Test::Builder::ok
94 my $ret = $tb->ok($same_bind, $msg);
98 _bind_differ_diag($bind_ref1, $bind_ref2);
101 # pass ok() result further
107 # if we save the instance, we will end up with $VARx references
108 # no time to figure out how to avoid this (Deepcopy is *not* an option)
109 require Data::Dumper;
110 Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
111 ->Values([@_])->Dump;
115 $tb->diag("Search term:\n" . &dumper);
118 sub _sql_differ_diag {
119 my $sql1 = shift || '';
120 my $sql2 = shift || '';
122 if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
123 my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
124 $_ = $sqlat->format($_) for ($sql1, $sql2);
127 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
128 "SQL expressions differ\n"
131 ."\nmismatch around\n$sql_differ\n"
135 sub _bind_differ_diag {
136 my ($bind_ref1, $bind_ref2) = @_;
138 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
139 "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
144 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
146 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
150 sub eq_bind { goto &Test::Deep::eq_deeply };
153 my ($sql1, $sql2) = @_;
156 my $tree1 = $sqlat->parse($sql1);
157 my $tree2 = $sqlat->parse($sql2);
160 return 1 if _eq_sql($tree1, $tree2);
164 my ($left, $right) = @_;
166 # one is defined the other not
167 if ((defined $left) xor (defined $right)) {
168 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
172 # one is undefined, then so is the other
173 elsif (not defined $left) {
178 elsif (@$left == 0 and @$right == 0) {
183 if (@$left == 0 or @$right == 0) {
184 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
188 # one is a list, the other is an op with a list
189 elsif (ref $left->[0] xor ref $right->[0]) {
190 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
191 { ref $_ ? $sqlat->unparse($_) : $_ }
192 ($left->[0], $right->[0], $left, $right)
198 elsif (ref $left->[0]) {
199 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
200 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
201 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
203 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
204 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
215 # unroll parenthesis if possible/allowed
216 unless ($parenthesis_significant) {
217 $sqlat->_parenthesis_unroll($_) for $left, $right;
220 # unroll ASC order by's
221 unless ($order_by_asc_significant) {
222 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
225 if ($left->[0] ne $right->[0]) {
226 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
227 $sqlat->unparse($left),
228 $sqlat->unparse($right)
233 # literals have a different arg-sig
234 elsif ($left->[0] eq '-LITERAL') {
235 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
236 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
237 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
238 $sql_differ = "[$l] != [$r]\n" if not $eq;
242 # if operators are identical, compare operands
244 my $eq = _eq_sql($left->[1], $right->[1]);
245 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
251 sub parse { $sqlat->parse(@_) }
259 SQL::Abstract::Test - Helper function for testing SQL::Abstract
265 use SQL::Abstract::Test import => [qw/
266 is_same_sql_bind is_same_sql is_same_bind
267 eq_sql_bind eq_sql eq_bind
270 my ($sql, @bind) = SQL::Abstract->new->select(%args);
272 is_same_sql_bind($given_sql, \@given_bind,
273 $expected_sql, \@expected_bind, $test_msg);
275 is_same_sql($given_sql, $expected_sql, $test_msg);
276 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
278 my $is_same = eq_sql_bind($given_sql, \@given_bind,
279 $expected_sql, \@expected_bind);
281 my $sql_same = eq_sql($given_sql, $expected_sql);
282 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
286 This module is only intended for authors of tests on
287 L<SQL::Abstract|SQL::Abstract> and related modules;
288 it exports functions for comparing two SQL statements
289 and their bound values.
291 The SQL comparison is performed on I<abstract syntax>,
292 ignoring differences in spaces or in levels of parentheses.
293 Therefore the tests will pass as long as the semantics
294 is preserved, even if the surface syntax has changed.
296 B<Disclaimer> : the semantic equivalence handling is pretty limited.
297 A lot of effort goes into distinguishing significant from
298 non-significant parenthesis, including AND/OR operator associativity.
299 Currently this module does not support commutativity and more
300 intelligent transformations like L<De Morgan's laws
301 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
303 For a good overview of what this test framework is currently capable of refer
308 =head2 is_same_sql_bind
311 $given_sql, \@given_bind,
312 $expected_sql, \@expected_bind,
317 \[$given_sql, @given_bind],
318 \[$expected_sql, @expected_bind],
324 $expected_sql, \@expected_bind,
328 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
329 as shown in the examples above and passing the arguments to L</eq_sql> and
330 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
331 C<$test_msg> as message.
332 If the test fails, a detailed diagnostic is printed.
342 Compares given and expected SQL statements via L</eq_sql>, and calls
343 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
344 If the test fails, a detailed diagnostic is printed.
354 Compares given and expected bind values via L</eq_bind>, and calls
355 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
356 If the test fails, a detailed diagnostic is printed.
360 my $is_same = eq_sql_bind(
361 $given_sql, \@given_bind,
362 $expected_sql, \@expected_bind,
365 my $is_same = eq_sql_bind(
366 \[$given_sql, @given_bind],
367 \[$expected_sql, @expected_bind],
370 my $is_same = eq_sql_bind(
372 $expected_sql, \@expected_bind,
375 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
376 L</eq_bind>, returning their combined result.
380 my $is_same = eq_sql($given_sql, $expected_sql);
382 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
383 but it just returns a boolean value and does not print diagnostics or talk to
384 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
385 will contain the SQL portion where a difference was encountered; this is useful
386 for printing diagnostics.
390 my $is_same = eq_sql(\@given_bind, \@expected_bind);
392 Compares two lists of bind values, taking into account the fact that some of
393 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
394 L</is_same_bind>, but it just returns a boolean value and does not print
395 diagnostics or talk to L<Test::Builder>.
397 =head1 GLOBAL VARIABLES
399 =head2 $case_sensitive
401 If true, SQL comparisons will be case-sensitive. Default is false;
403 =head2 $parenthesis_significant
405 If true, SQL comparison will preserve and report difference in nested
406 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
409 =head2 $order_by_asc_significant
411 If true SQL comparison will consider C<ORDER BY foo ASC> and
412 C<ORDER BY foo> to be different. Default is false;
416 When L</eq_sql> returns false, the global variable
417 C<$sql_differ> contains the SQL portion
418 where a difference was encountered.
422 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
426 Laurent Dami <laurent.dami AT etat geneve ch>
428 Norbert Buchmuller <norbi@nix.hu>
430 Peter Rabbitson <ribasushi@cpan.org>
432 =head1 COPYRIGHT AND LICENSE
434 Copyright 2008 by Laurent Dami.
436 This library is free software; you can redistribute it and/or modify
437 it under the same terms as Perl itself.