1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw(Test::Builder::Module Exporter);
8 use SQL::Abstract::Tree;
12 if ($class = $ENV{SQL_ABSTRACT_TEST_AGAINST}) {
13 my $mod = join('/', split '::', $class).".pm";
15 eval qq{sub SQL::Abstract () { "\Q${class}\E" }; 1}
16 or die "Failed to create const sub for ${class}: $@";
18 if ($ENV{SQL_ABSTRACT_TEST_EXPAND_STABILITY}) {
19 $class ||= do { require SQL::Abstract; 'SQL::Abstract' };
20 my $orig = $class->can('expand_expr');
21 require Data::Dumper::Concise;
23 my ($self, @args) = @_;
24 my $e1 = $self->$orig(@args);
25 my $e2 = $self->$orig($e1);
27 (map Data::Dumper::Concise::Dumper($_), $e1, $e2),
28 'expand_expr stability ok'
32 no strict 'refs'; no warnings 'redefine';
33 *{"${class}::expand_expr"} = $wrapped;
38 is_same_sql_bind is_same_sql is_same_bind
39 eq_sql_bind eq_sql eq_bind dumper diag_where
40 $case_sensitive $sql_differ
43 my $sqlat = SQL::Abstract::Tree->new;
45 our $case_sensitive = 0;
46 our $parenthesis_significant = 0;
47 our $order_by_asc_significant = 0;
49 our $sql_differ; # keeps track of differing portion between SQLs
50 our $tb = __PACKAGE__->builder;
52 sub _unpack_arrayrefref {
58 if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') {
59 my ($sql, @bind) = @$$chunk;
60 push @args, ($sql, \@bind);
63 push @args, $chunk, shift @_;
68 # maybe $msg and ... stuff
74 sub is_same_sql_bind {
75 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref;
78 my $same_sql = eq_sql($sql1, $sql2);
79 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
81 # call Test::Builder::ok
82 my $ret = $tb->ok($same_sql && $same_bind, $msg);
86 _sql_differ_diag($sql1, $sql2);
89 _bind_differ_diag($bind_ref1, $bind_ref2);
92 # pass ok() result further
97 my ($sql1, $sql2, $msg) = @_;
100 my $same_sql = eq_sql($sql1, $sql2);
102 # call Test::Builder::ok
103 my $ret = $tb->ok($same_sql, $msg);
107 _sql_differ_diag($sql1, $sql2);
110 # pass ok() result further
115 my ($bind_ref1, $bind_ref2, $msg) = @_;
118 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
120 # call Test::Builder::ok
121 my $ret = $tb->ok($same_bind, $msg);
125 _bind_differ_diag($bind_ref1, $bind_ref2);
128 # pass ok() result further
134 # if we save the instance, we will end up with $VARx references
135 # no time to figure out how to avoid this (Deepcopy is *not* an option)
136 require Data::Dumper;
137 Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
138 ->Values([@_])->Dump;
142 $tb->diag("Search term:\n" . &dumper);
145 sub _sql_differ_diag {
146 my $sql1 = shift || '';
147 my $sql2 = shift || '';
149 if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
150 my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
151 $_ = $sqlat->format($_) for ($sql1, $sql2);
154 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
155 "SQL expressions differ\n"
158 ."\nmismatch around\n$sql_differ\n"
162 sub _bind_differ_diag {
163 my ($bind_ref1, $bind_ref2) = @_;
165 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
166 "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
171 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
173 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
177 sub eq_bind { goto &Test::Deep::eq_deeply };
180 my ($sql1, $sql2) = @_;
183 my $tree1 = $sqlat->parse($sql1);
184 my $tree2 = $sqlat->parse($sql2);
187 return 1 if _eq_sql($tree1, $tree2);
191 my ($left, $right) = @_;
193 # one is defined the other not
194 if ((defined $left) xor (defined $right)) {
195 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
199 # one is undefined, then so is the other
200 elsif (not defined $left) {
205 elsif (@$left == 0 and @$right == 0) {
210 if (@$left == 0 or @$right == 0) {
211 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
215 # one is a list, the other is an op with a list
216 elsif (ref $left->[0] xor ref $right->[0]) {
217 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
218 { ref $_ ? $sqlat->unparse($_) : $_ }
219 ($left->[0], $right->[0], $left, $right)
225 elsif (ref $left->[0]) {
226 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
227 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
228 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
230 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
231 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
242 # unroll parenthesis if possible/allowed
243 unless ($parenthesis_significant) {
244 $sqlat->_parenthesis_unroll($_) for $left, $right;
247 # unroll ASC order by's
248 unless ($order_by_asc_significant) {
249 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
252 if ($left->[0] ne $right->[0]) {
253 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
254 $sqlat->unparse($left),
255 $sqlat->unparse($right)
260 # literals have a different arg-sig
261 elsif ($left->[0] eq '-LITERAL') {
262 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
263 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
264 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
265 $sql_differ = "[$l] != [$r]\n" if not $eq;
269 # if operators are identical, compare operands
271 my $eq = _eq_sql($left->[1], $right->[1]);
272 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
278 sub parse { $sqlat->parse(@_) }
286 SQL::Abstract::Test - Helper function for testing SQL::Abstract
292 use SQL::Abstract::Test import => [qw/
293 is_same_sql_bind is_same_sql is_same_bind
294 eq_sql_bind eq_sql eq_bind
297 my ($sql, @bind) = SQL::Abstract->new->select(%args);
299 is_same_sql_bind($given_sql, \@given_bind,
300 $expected_sql, \@expected_bind, $test_msg);
302 is_same_sql($given_sql, $expected_sql, $test_msg);
303 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
305 my $is_same = eq_sql_bind($given_sql, \@given_bind,
306 $expected_sql, \@expected_bind);
308 my $sql_same = eq_sql($given_sql, $expected_sql);
309 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
313 This module is only intended for authors of tests on
314 L<SQL::Abstract|SQL::Abstract> and related modules;
315 it exports functions for comparing two SQL statements
316 and their bound values.
318 The SQL comparison is performed on I<abstract syntax>,
319 ignoring differences in spaces or in levels of parentheses.
320 Therefore the tests will pass as long as the semantics
321 is preserved, even if the surface syntax has changed.
323 B<Disclaimer> : the semantic equivalence handling is pretty limited.
324 A lot of effort goes into distinguishing significant from
325 non-significant parenthesis, including AND/OR operator associativity.
326 Currently this module does not support commutativity and more
327 intelligent transformations like L<De Morgan's laws
328 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
330 For a good overview of what this test framework is currently capable of refer
335 =head2 is_same_sql_bind
338 $given_sql, \@given_bind,
339 $expected_sql, \@expected_bind,
344 \[$given_sql, @given_bind],
345 \[$expected_sql, @expected_bind],
351 $expected_sql, \@expected_bind,
355 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
356 as shown in the examples above and passing the arguments to L</eq_sql> and
357 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
358 C<$test_msg> as message.
359 If the test fails, a detailed diagnostic is printed.
369 Compares given and expected SQL statements via L</eq_sql>, and calls
370 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
371 If the test fails, a detailed diagnostic is printed.
381 Compares given and expected bind values via L</eq_bind>, and calls
382 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
383 If the test fails, a detailed diagnostic is printed.
387 my $is_same = eq_sql_bind(
388 $given_sql, \@given_bind,
389 $expected_sql, \@expected_bind,
392 my $is_same = eq_sql_bind(
393 \[$given_sql, @given_bind],
394 \[$expected_sql, @expected_bind],
397 my $is_same = eq_sql_bind(
399 $expected_sql, \@expected_bind,
402 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
403 L</eq_bind>, returning their combined result.
407 my $is_same = eq_sql($given_sql, $expected_sql);
409 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
410 but it just returns a boolean value and does not print diagnostics or talk to
411 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
412 will contain the SQL portion where a difference was encountered; this is useful
413 for printing diagnostics.
417 my $is_same = eq_sql(\@given_bind, \@expected_bind);
419 Compares two lists of bind values, taking into account the fact that some of
420 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
421 L</is_same_bind>, but it just returns a boolean value and does not print
422 diagnostics or talk to L<Test::Builder>.
424 =head1 GLOBAL VARIABLES
426 =head2 $case_sensitive
428 If true, SQL comparisons will be case-sensitive. Default is false;
430 =head2 $parenthesis_significant
432 If true, SQL comparison will preserve and report difference in nested
433 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
436 =head2 $order_by_asc_significant
438 If true SQL comparison will consider C<ORDER BY foo ASC> and
439 C<ORDER BY foo> to be different. Default is false;
443 When L</eq_sql> returns false, the global variable
444 C<$sql_differ> contains the SQL portion
445 where a difference was encountered.
449 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
453 Laurent Dami <laurent.dami AT etat geneve ch>
455 Norbert Buchmuller <norbi@nix.hu>
457 Peter Rabbitson <ribasushi@cpan.org>
459 =head1 COPYRIGHT AND LICENSE
461 Copyright 2008 by Laurent Dami.
463 This library is free software; you can redistribute it and/or modify
464 it under the same terms as Perl itself.