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 $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
123 "SQL expressions differ\n"
126 ."\nmismatch around\n$sql_differ\n"
130 sub _bind_differ_diag {
131 my ($bind_ref1, $bind_ref2) = @_;
133 $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
134 "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
139 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
141 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
145 sub eq_bind { goto &Test::Deep::eq_deeply };
148 my ($sql1, $sql2) = @_;
151 my $tree1 = $sqlat->parse($sql1);
152 my $tree2 = $sqlat->parse($sql2);
155 return 1 if _eq_sql($tree1, $tree2);
159 my ($left, $right) = @_;
161 # one is defined the other not
162 if ( (defined $left) xor (defined $right) ) {
163 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
167 # one is undefined, then so is the other
168 elsif (not defined $left) {
173 elsif (@$left == 0 and @$right == 0) {
178 if (@$left == 0 or @$right == 0) {
179 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
183 # one is a list, the other is an op with a list
184 elsif (ref $left->[0] xor ref $right->[0]) {
185 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
186 { ref $_ ? $sqlat->unparse ($_) : $_ }
187 ($left->[0], $right->[0], $left, $right)
193 elsif (ref $left->[0]) {
194 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
195 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
196 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
198 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
199 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
210 # unroll parenthesis if possible/allowed
211 unless ( $parenthesis_significant ) {
212 $sqlat->_parenthesis_unroll($_) for $left, $right;
215 # unroll ASC order by's
216 unless ($order_by_asc_significant) {
217 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
220 if ( $left->[0] ne $right->[0] ) {
221 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
222 $sqlat->unparse($left),
223 $sqlat->unparse($right)
228 # literals have a different arg-sig
229 elsif ($left->[0] eq '-LITERAL') {
230 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
231 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
232 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
233 $sql_differ = "[$l] != [$r]\n" if not $eq;
237 # if operators are identical, compare operands
239 my $eq = _eq_sql($left->[1], $right->[1]);
240 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
246 sub parse { $sqlat->parse(@_) }
254 SQL::Abstract::Test - Helper function for testing SQL::Abstract
260 use SQL::Abstract::Test import => [qw/
261 is_same_sql_bind is_same_sql is_same_bind
262 eq_sql_bind eq_sql eq_bind
265 my ($sql, @bind) = SQL::Abstract->new->select(%args);
267 is_same_sql_bind($given_sql, \@given_bind,
268 $expected_sql, \@expected_bind, $test_msg);
270 is_same_sql($given_sql, $expected_sql, $test_msg);
271 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
273 my $is_same = eq_sql_bind($given_sql, \@given_bind,
274 $expected_sql, \@expected_bind);
276 my $sql_same = eq_sql($given_sql, $expected_sql);
277 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
281 This module is only intended for authors of tests on
282 L<SQL::Abstract|SQL::Abstract> and related modules;
283 it exports functions for comparing two SQL statements
284 and their bound values.
286 The SQL comparison is performed on I<abstract syntax>,
287 ignoring differences in spaces or in levels of parentheses.
288 Therefore the tests will pass as long as the semantics
289 is preserved, even if the surface syntax has changed.
291 B<Disclaimer> : the semantic equivalence handling is pretty limited.
292 A lot of effort goes into distinguishing significant from
293 non-significant parenthesis, including AND/OR operator associativity.
294 Currently this module does not support commutativity and more
295 intelligent transformations like L<De Morgan's laws
296 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
298 For a good overview of what this test framework is currently capable of refer
303 =head2 is_same_sql_bind
306 $given_sql, \@given_bind,
307 $expected_sql, \@expected_bind,
312 \[$given_sql, @given_bind],
313 \[$expected_sql, @expected_bind],
319 $expected_sql, \@expected_bind,
323 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
324 as shown in the examples above and passing the arguments to L</eq_sql> and
325 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
326 C<$test_msg> as message.
327 If the test fails, a detailed diagnostic is printed.
337 Compares given and expected SQL statements via L</eq_sql>, and calls
338 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
339 If the test fails, a detailed diagnostic is printed.
349 Compares given and expected bind values via L</eq_bind>, and calls
350 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
351 If the test fails, a detailed diagnostic is printed.
355 my $is_same = eq_sql_bind(
356 $given_sql, \@given_bind,
357 $expected_sql, \@expected_bind,
360 my $is_same = eq_sql_bind(
361 \[$given_sql, @given_bind],
362 \[$expected_sql, @expected_bind],
365 my $is_same = eq_sql_bind(
367 $expected_sql, \@expected_bind,
370 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
371 L</eq_bind>, returning their combined result.
375 my $is_same = eq_sql($given_sql, $expected_sql);
377 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
378 but it just returns a boolean value and does not print diagnostics or talk to
379 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
380 will contain the SQL portion where a difference was encountered; this is useful
381 for printing diagnostics.
385 my $is_same = eq_sql(\@given_bind, \@expected_bind);
387 Compares two lists of bind values, taking into account the fact that some of
388 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
389 L</is_same_bind>, but it just returns a boolean value and does not print
390 diagnostics or talk to L<Test::Builder>.
392 =head1 GLOBAL VARIABLES
394 =head2 $case_sensitive
396 If true, SQL comparisons will be case-sensitive. Default is false;
398 =head2 $parenthesis_significant
400 If true, SQL comparison will preserve and report difference in nested
401 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
404 =head2 $order_by_asc_significant
406 If true SQL comparison will consider C<ORDER BY foo ASC> and
407 C<ORDER BY foo> to be different. Default is false;
411 When L</eq_sql> returns false, the global variable
412 C<$sql_differ> contains the SQL portion
413 where a difference was encountered.
417 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
421 Laurent Dami <laurent.dami AT etat geneve ch>
423 Norbert Buchmuller <norbi@nix.hu>
425 Peter Rabbitson <ribasushi@cpan.org>
427 =head1 COPYRIGHT AND LICENSE
429 Copyright 2008 by Laurent Dami.
431 This library is free software; you can redistribute it and/or modify
432 it under the same terms as Perl itself.