1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw(Test::Builder::Module);
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 return $e1 if our $Stab_Check_Rec;
26 local $Stab_Check_Rec = 1;
27 my $e2 = $self->$orig($e1);
28 my ($d1, $d2) = map Data::Dumper::Concise::Dumper($_), $e1, $e2;
31 'expand_expr stability ok'
34 Path::Tiny->new('e1')->spew($d1);
35 Path::Tiny->new('e2')->spew($d2);
36 system('diff -u e1 e2 1>&2');
37 die "Differences between e1 and e2, bailing out";
41 no strict 'refs'; no warnings 'redefine';
42 *{"${class}::expand_expr"} = $wrapped;
47 is_same_sql_bind is_same_sql is_same_bind
48 eq_sql_bind eq_sql eq_bind dumper diag_where
49 $case_sensitive $sql_differ
52 my $sqlat = SQL::Abstract::Tree->new;
54 our $case_sensitive = 0;
55 our $parenthesis_significant = 0;
56 our $order_by_asc_significant = 0;
58 our $sql_differ; # keeps track of differing portion between SQLs
59 our $tb; # not documented, but someone might be overriding it anyway
61 sub _unpack_arrayrefref {
67 if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') {
68 my ($sql, @bind) = @$$chunk;
69 push @args, ($sql, \@bind);
72 push @args, $chunk, shift @_;
77 # maybe $msg and ... stuff
83 sub is_same_sql_bind {
84 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref;
87 my $same_sql = eq_sql($sql1, $sql2);
88 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
90 # call Test::Builder::ok
91 my $tb = $tb || __PACKAGE__->builder;
92 my $ret = $tb->ok($same_sql && $same_bind, $msg);
96 _sql_differ_diag($sql1, $sql2);
99 _bind_differ_diag($bind_ref1, $bind_ref2);
102 # pass ok() result further
107 my ($sql1, $sql2, $msg) = @_;
110 my $same_sql = eq_sql($sql1, $sql2);
112 # call Test::Builder::ok
113 my $tb = $tb || __PACKAGE__->builder;
114 my $ret = $tb->ok($same_sql, $msg);
118 _sql_differ_diag($sql1, $sql2);
121 # pass ok() result further
126 my ($bind_ref1, $bind_ref2, $msg) = @_;
129 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
131 # call Test::Builder::ok
132 my $tb = $tb || __PACKAGE__->builder;
133 my $ret = $tb->ok($same_bind, $msg);
137 _bind_differ_diag($bind_ref1, $bind_ref2);
140 # pass ok() result further
146 # if we save the instance, we will end up with $VARx references
147 # no time to figure out how to avoid this (Deepcopy is *not* an option)
148 require Data::Dumper;
149 Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
150 ->Values([@_])->Dump;
154 my $tb = $tb || __PACKAGE__->builder;
155 $tb->diag("Search term:\n" . &dumper);
158 sub _sql_differ_diag {
159 my $sql1 = shift || '';
160 my $sql2 = shift || '';
162 my $tb = $tb || __PACKAGE__->builder;
164 if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
165 my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
166 $_ = $sqlat->format($_) for ($sql1, $sql2);
169 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
170 "SQL expressions differ\n"
173 ."\nmismatch around\n$sql_differ\n"
177 sub _bind_differ_diag {
178 my ($bind_ref1, $bind_ref2) = @_;
180 my $tb = $tb || __PACKAGE__->builder;
181 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
182 "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
187 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
189 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
193 sub eq_bind { goto &Test::Deep::eq_deeply };
196 my ($sql1, $sql2) = @_;
199 my $tree1 = $sqlat->parse($sql1);
200 my $tree2 = $sqlat->parse($sql2);
203 return 1 if _eq_sql($tree1, $tree2);
207 my ($left, $right) = @_;
209 # one is defined the other not
210 if ((defined $left) xor (defined $right)) {
211 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
215 # one is undefined, then so is the other
216 elsif (not defined $left) {
221 elsif (@$left == 0 and @$right == 0) {
226 if (@$left == 0 or @$right == 0) {
227 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
231 # one is a list, the other is an op with a list
232 elsif (ref $left->[0] xor ref $right->[0]) {
233 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
234 { ref $_ ? $sqlat->unparse($_) : $_ }
235 ($left->[0], $right->[0], $left, $right)
241 elsif (ref $left->[0]) {
242 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
243 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
244 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
246 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
247 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
258 # unroll parenthesis if possible/allowed
259 unless ($parenthesis_significant) {
260 $sqlat->_parenthesis_unroll($_) for $left, $right;
263 # unroll ASC order by's
264 unless ($order_by_asc_significant) {
265 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
268 if ($left->[0] ne $right->[0]) {
269 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
270 $sqlat->unparse($left),
271 $sqlat->unparse($right)
276 # literals have a different arg-sig
277 elsif ($left->[0] eq '-LITERAL') {
278 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
279 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
280 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
281 $sql_differ = "[$l] != [$r]\n" if not $eq;
285 # if operators are identical, compare operands
287 my $eq = _eq_sql($left->[1], $right->[1]);
288 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
294 sub parse { $sqlat->parse(@_) }
302 SQL::Abstract::Test - Helper function for testing SQL::Abstract
308 use SQL::Abstract::Test import => [qw/
309 is_same_sql_bind is_same_sql is_same_bind
310 eq_sql_bind eq_sql eq_bind
313 my ($sql, @bind) = SQL::Abstract->new->select(%args);
315 is_same_sql_bind($given_sql, \@given_bind,
316 $expected_sql, \@expected_bind, $test_msg);
318 is_same_sql($given_sql, $expected_sql, $test_msg);
319 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
321 my $is_same = eq_sql_bind($given_sql, \@given_bind,
322 $expected_sql, \@expected_bind);
324 my $sql_same = eq_sql($given_sql, $expected_sql);
325 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
329 This module is only intended for authors of tests on
330 L<SQL::Abstract|SQL::Abstract> and related modules;
331 it exports functions for comparing two SQL statements
332 and their bound values.
334 The SQL comparison is performed on I<abstract syntax>,
335 ignoring differences in spaces or in levels of parentheses.
336 Therefore the tests will pass as long as the semantics
337 is preserved, even if the surface syntax has changed.
339 B<Disclaimer> : the semantic equivalence handling is pretty limited.
340 A lot of effort goes into distinguishing significant from
341 non-significant parenthesis, including AND/OR operator associativity.
342 Currently this module does not support commutativity and more
343 intelligent transformations like L<De Morgan's laws
344 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
346 For a good overview of what this test framework is currently capable of refer
351 =head2 is_same_sql_bind
354 $given_sql, \@given_bind,
355 $expected_sql, \@expected_bind,
360 \[$given_sql, @given_bind],
361 \[$expected_sql, @expected_bind],
367 $expected_sql, \@expected_bind,
371 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
372 as shown in the examples above and passing the arguments to L</eq_sql> and
373 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
374 C<$test_msg> as message.
375 If the test fails, a detailed diagnostic is printed.
385 Compares given and expected SQL statements via L</eq_sql>, and calls
386 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
387 If the test fails, a detailed diagnostic is printed.
397 Compares given and expected bind values via L</eq_bind>, and calls
398 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
399 If the test fails, a detailed diagnostic is printed.
403 my $is_same = eq_sql_bind(
404 $given_sql, \@given_bind,
405 $expected_sql, \@expected_bind,
408 my $is_same = eq_sql_bind(
409 \[$given_sql, @given_bind],
410 \[$expected_sql, @expected_bind],
413 my $is_same = eq_sql_bind(
415 $expected_sql, \@expected_bind,
418 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
419 L</eq_bind>, returning their combined result.
423 my $is_same = eq_sql($given_sql, $expected_sql);
425 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
426 but it just returns a boolean value and does not print diagnostics or talk to
427 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
428 will contain the SQL portion where a difference was encountered; this is useful
429 for printing diagnostics.
433 my $is_same = eq_sql(\@given_bind, \@expected_bind);
435 Compares two lists of bind values, taking into account the fact that some of
436 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
437 L</is_same_bind>, but it just returns a boolean value and does not print
438 diagnostics or talk to L<Test::Builder>.
440 =head1 GLOBAL VARIABLES
442 =head2 $case_sensitive
444 If true, SQL comparisons will be case-sensitive. Default is false;
446 =head2 $parenthesis_significant
448 If true, SQL comparison will preserve and report difference in nested
449 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
452 =head2 $order_by_asc_significant
454 If true SQL comparison will consider C<ORDER BY foo ASC> and
455 C<ORDER BY foo> to be different. Default is false;
459 When L</eq_sql> returns false, the global variable
460 C<$sql_differ> contains the SQL portion
461 where a difference was encountered.
465 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
469 Laurent Dami <laurent.dami AT etat geneve ch>
471 Norbert Buchmuller <norbi@nix.hu>
473 Peter Rabbitson <ribasushi@cpan.org>
475 =head1 COPYRIGHT AND LICENSE
477 Copyright 2008 by Laurent Dami.
479 This library is free software; you can redistribute it and/or modify
480 it under the same terms as Perl itself.