1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw(Test::Builder::Module);
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; # not documented, but someone might be overriding it anyway
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 $tb = $tb || __PACKAGE__->builder;
56 my $ret = $tb->ok($same_sql && $same_bind, $msg);
60 _sql_differ_diag($sql1, $sql2);
63 _bind_differ_diag($bind_ref1, $bind_ref2);
66 # pass ok() result further
71 my ($sql1, $sql2, $msg) = @_;
74 my $same_sql = eq_sql($sql1, $sql2);
76 # call Test::Builder::ok
77 my $tb = $tb || __PACKAGE__->builder;
78 my $ret = $tb->ok($same_sql, $msg);
82 _sql_differ_diag($sql1, $sql2);
85 # pass ok() result further
90 my ($bind_ref1, $bind_ref2, $msg) = @_;
93 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
95 # call Test::Builder::ok
96 my $tb = $tb || __PACKAGE__->builder;
97 my $ret = $tb->ok($same_bind, $msg);
101 _bind_differ_diag($bind_ref1, $bind_ref2);
104 # pass ok() result further
110 # if we save the instance, we will end up with $VARx references
111 # no time to figure out how to avoid this (Deepcopy is *not* an option)
112 require Data::Dumper;
113 Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
114 ->Values([@_])->Dump;
118 my $tb = $tb || __PACKAGE__->builder;
119 $tb->diag("Search term:\n" . &dumper);
122 sub _sql_differ_diag {
123 my $sql1 = shift || '';
124 my $sql2 = shift || '';
126 my $tb = $tb || __PACKAGE__->builder;
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 my $tb = $tb || __PACKAGE__->builder;
139 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
140 "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
145 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
147 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
151 sub eq_bind { goto &Test::Deep::eq_deeply };
154 my ($sql1, $sql2) = @_;
157 my $tree1 = $sqlat->parse($sql1);
158 my $tree2 = $sqlat->parse($sql2);
161 return 1 if _eq_sql($tree1, $tree2);
165 my ($left, $right) = @_;
167 # one is defined the other not
168 if ((defined $left) xor (defined $right)) {
169 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
173 # one is undefined, then so is the other
174 elsif (not defined $left) {
179 elsif (@$left == 0 and @$right == 0) {
184 if (@$left == 0 or @$right == 0) {
185 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
189 # one is a list, the other is an op with a list
190 elsif (ref $left->[0] xor ref $right->[0]) {
191 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
192 { ref $_ ? $sqlat->unparse($_) : $_ }
193 ($left->[0], $right->[0], $left, $right)
199 elsif (ref $left->[0]) {
200 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
201 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
202 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
204 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
205 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
216 # unroll parenthesis if possible/allowed
217 unless ($parenthesis_significant) {
218 $sqlat->_parenthesis_unroll($_) for $left, $right;
221 # unroll ASC order by's
222 unless ($order_by_asc_significant) {
223 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
226 if ($left->[0] ne $right->[0]) {
227 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
228 $sqlat->unparse($left),
229 $sqlat->unparse($right)
234 # literals have a different arg-sig
235 elsif ($left->[0] eq '-LITERAL') {
236 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
237 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
238 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
239 $sql_differ = "[$l] != [$r]\n" if not $eq;
243 # if operators are identical, compare operands
245 my $eq = _eq_sql($left->[1], $right->[1]);
246 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
252 sub parse { $sqlat->parse(@_) }
260 SQL::Abstract::Test - Helper function for testing SQL::Abstract
266 use SQL::Abstract::Test import => [qw/
267 is_same_sql_bind is_same_sql is_same_bind
268 eq_sql_bind eq_sql eq_bind
271 my ($sql, @bind) = SQL::Abstract->new->select(%args);
273 is_same_sql_bind($given_sql, \@given_bind,
274 $expected_sql, \@expected_bind, $test_msg);
276 is_same_sql($given_sql, $expected_sql, $test_msg);
277 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
279 my $is_same = eq_sql_bind($given_sql, \@given_bind,
280 $expected_sql, \@expected_bind);
282 my $sql_same = eq_sql($given_sql, $expected_sql);
283 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
287 This module is only intended for authors of tests on
288 L<SQL::Abstract|SQL::Abstract> and related modules;
289 it exports functions for comparing two SQL statements
290 and their bound values.
292 The SQL comparison is performed on I<abstract syntax>,
293 ignoring differences in spaces or in levels of parentheses.
294 Therefore the tests will pass as long as the semantics
295 is preserved, even if the surface syntax has changed.
297 B<Disclaimer> : the semantic equivalence handling is pretty limited.
298 A lot of effort goes into distinguishing significant from
299 non-significant parenthesis, including AND/OR operator associativity.
300 Currently this module does not support commutativity and more
301 intelligent transformations like L<De Morgan's laws
302 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
304 For a good overview of what this test framework is currently capable of refer
309 =head2 is_same_sql_bind
312 $given_sql, \@given_bind,
313 $expected_sql, \@expected_bind,
318 \[$given_sql, @given_bind],
319 \[$expected_sql, @expected_bind],
325 $expected_sql, \@expected_bind,
329 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
330 as shown in the examples above and passing the arguments to L</eq_sql> and
331 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
332 C<$test_msg> as message.
333 If the test fails, a detailed diagnostic is printed.
343 Compares given and expected SQL statements via L</eq_sql>, and calls
344 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
345 If the test fails, a detailed diagnostic is printed.
355 Compares given and expected bind values via L</eq_bind>, and calls
356 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
357 If the test fails, a detailed diagnostic is printed.
361 my $is_same = eq_sql_bind(
362 $given_sql, \@given_bind,
363 $expected_sql, \@expected_bind,
366 my $is_same = eq_sql_bind(
367 \[$given_sql, @given_bind],
368 \[$expected_sql, @expected_bind],
371 my $is_same = eq_sql_bind(
373 $expected_sql, \@expected_bind,
376 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
377 L</eq_bind>, returning their combined result.
381 my $is_same = eq_sql($given_sql, $expected_sql);
383 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
384 but it just returns a boolean value and does not print diagnostics or talk to
385 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
386 will contain the SQL portion where a difference was encountered; this is useful
387 for printing diagnostics.
391 my $is_same = eq_sql(\@given_bind, \@expected_bind);
393 Compares two lists of bind values, taking into account the fact that some of
394 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
395 L</is_same_bind>, but it just returns a boolean value and does not print
396 diagnostics or talk to L<Test::Builder>.
398 =head1 GLOBAL VARIABLES
400 =head2 $case_sensitive
402 If true, SQL comparisons will be case-sensitive. Default is false;
404 =head2 $parenthesis_significant
406 If true, SQL comparison will preserve and report difference in nested
407 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
410 =head2 $order_by_asc_significant
412 If true SQL comparison will consider C<ORDER BY foo ASC> and
413 C<ORDER BY foo> to be different. Default is false;
417 When L</eq_sql> returns false, the global variable
418 C<$sql_differ> contains the SQL portion
419 where a difference was encountered.
423 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
427 Laurent Dami <laurent.dami AT etat geneve ch>
429 Norbert Buchmuller <norbi@nix.hu>
431 Peter Rabbitson <ribasushi@cpan.org>
433 =head1 COPYRIGHT AND LICENSE
435 Copyright 2008 by Laurent Dami.
437 This library is free software; you can redistribute it and/or modify
438 it under the same terms as Perl itself.