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;
128 if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
129 my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
130 $_ = $sqlat->format($_) for ($sql1, $sql2);
133 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
134 "SQL expressions differ\n"
137 ."\nmismatch around\n$sql_differ\n"
141 sub _bind_differ_diag {
142 my ($bind_ref1, $bind_ref2) = @_;
144 my $tb = $tb || __PACKAGE__->builder;
145 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
146 "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
151 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
153 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
157 sub eq_bind { goto &Test::Deep::eq_deeply };
160 my ($sql1, $sql2) = @_;
163 my $tree1 = $sqlat->parse($sql1);
164 my $tree2 = $sqlat->parse($sql2);
167 return 1 if _eq_sql($tree1, $tree2);
171 my ($left, $right) = @_;
173 # one is defined the other not
174 if ((defined $left) xor (defined $right)) {
175 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
179 # one is undefined, then so is the other
180 elsif (not defined $left) {
185 elsif (@$left == 0 and @$right == 0) {
190 if (@$left == 0 or @$right == 0) {
191 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
195 # one is a list, the other is an op with a list
196 elsif (ref $left->[0] xor ref $right->[0]) {
197 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
198 { ref $_ ? $sqlat->unparse($_) : $_ }
199 ($left->[0], $right->[0], $left, $right)
205 elsif (ref $left->[0]) {
206 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
207 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
208 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
210 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
211 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
222 # unroll parenthesis if possible/allowed
223 unless ($parenthesis_significant) {
224 $sqlat->_parenthesis_unroll($_) for $left, $right;
227 # unroll ASC order by's
228 unless ($order_by_asc_significant) {
229 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
232 if ($left->[0] ne $right->[0]) {
233 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
234 $sqlat->unparse($left),
235 $sqlat->unparse($right)
240 # literals have a different arg-sig
241 elsif ($left->[0] eq '-LITERAL') {
242 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
243 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
244 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
245 $sql_differ = "[$l] != [$r]\n" if not $eq;
249 # if operators are identical, compare operands
251 my $eq = _eq_sql($left->[1], $right->[1]);
252 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
258 sub parse { $sqlat->parse(@_) }
266 SQL::Abstract::Test - Helper function for testing SQL::Abstract
272 use SQL::Abstract::Test import => [qw/
273 is_same_sql_bind is_same_sql is_same_bind
274 eq_sql_bind eq_sql eq_bind
277 my ($sql, @bind) = SQL::Abstract->new->select(%args);
279 is_same_sql_bind($given_sql, \@given_bind,
280 $expected_sql, \@expected_bind, $test_msg);
282 is_same_sql($given_sql, $expected_sql, $test_msg);
283 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
285 my $is_same = eq_sql_bind($given_sql, \@given_bind,
286 $expected_sql, \@expected_bind);
288 my $sql_same = eq_sql($given_sql, $expected_sql);
289 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
293 This module is only intended for authors of tests on
294 L<SQL::Abstract|SQL::Abstract> and related modules;
295 it exports functions for comparing two SQL statements
296 and their bound values.
298 The SQL comparison is performed on I<abstract syntax>,
299 ignoring differences in spaces or in levels of parentheses.
300 Therefore the tests will pass as long as the semantics
301 is preserved, even if the surface syntax has changed.
303 B<Disclaimer> : the semantic equivalence handling is pretty limited.
304 A lot of effort goes into distinguishing significant from
305 non-significant parenthesis, including AND/OR operator associativity.
306 Currently this module does not support commutativity and more
307 intelligent transformations like L<De Morgan's laws
308 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
310 For a good overview of what this test framework is currently capable of refer
315 =head2 is_same_sql_bind
318 $given_sql, \@given_bind,
319 $expected_sql, \@expected_bind,
324 \[$given_sql, @given_bind],
325 \[$expected_sql, @expected_bind],
331 $expected_sql, \@expected_bind,
335 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
336 as shown in the examples above and passing the arguments to L</eq_sql> and
337 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
338 C<$test_msg> as message.
339 If the test fails, a detailed diagnostic is printed.
349 Compares given and expected SQL statements via L</eq_sql>, 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.
361 Compares given and expected bind values via L</eq_bind>, and calls
362 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
363 If the test fails, a detailed diagnostic is printed.
367 my $is_same = eq_sql_bind(
368 $given_sql, \@given_bind,
369 $expected_sql, \@expected_bind,
372 my $is_same = eq_sql_bind(
373 \[$given_sql, @given_bind],
374 \[$expected_sql, @expected_bind],
377 my $is_same = eq_sql_bind(
379 $expected_sql, \@expected_bind,
382 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
383 L</eq_bind>, returning their combined result.
387 my $is_same = eq_sql($given_sql, $expected_sql);
389 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
390 but it just returns a boolean value and does not print diagnostics or talk to
391 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
392 will contain the SQL portion where a difference was encountered; this is useful
393 for printing diagnostics.
397 my $is_same = eq_sql(\@given_bind, \@expected_bind);
399 Compares two lists of bind values, taking into account the fact that some of
400 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
401 L</is_same_bind>, but it just returns a boolean value and does not print
402 diagnostics or talk to L<Test::Builder>.
404 =head1 GLOBAL VARIABLES
406 =head2 $case_sensitive
408 If true, SQL comparisons will be case-sensitive. Default is false;
410 =head2 $parenthesis_significant
412 If true, SQL comparison will preserve and report difference in nested
413 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
416 =head2 $order_by_asc_significant
418 If true SQL comparison will consider C<ORDER BY foo ASC> and
419 C<ORDER BY foo> to be different. Default is false;
423 When L</eq_sql> returns false, the global variable
424 C<$sql_differ> contains the SQL portion
425 where a difference was encountered.
429 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
433 Laurent Dami <laurent.dami AT etat geneve ch>
435 Norbert Buchmuller <norbi@nix.hu>
437 Peter Rabbitson <ribasushi@cpan.org>
439 =head1 COPYRIGHT AND LICENSE
441 Copyright 2008 by Laurent Dami.
443 This library is free software; you can redistribute it and/or modify
444 it under the same terms as Perl itself.