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 die "Wrote e1 and e2, bailing out";
40 no strict 'refs'; no warnings 'redefine';
41 *{"${class}::expand_expr"} = $wrapped;
46 is_same_sql_bind is_same_sql is_same_bind
47 eq_sql_bind eq_sql eq_bind dumper diag_where
48 $case_sensitive $sql_differ
51 my $sqlat = SQL::Abstract::Tree->new;
53 our $case_sensitive = 0;
54 our $parenthesis_significant = 0;
55 our $order_by_asc_significant = 0;
57 our $sql_differ; # keeps track of differing portion between SQLs
58 our $tb; # not documented, but someone might be overriding it anyway
60 sub _unpack_arrayrefref {
66 if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') {
67 my ($sql, @bind) = @$$chunk;
68 push @args, ($sql, \@bind);
71 push @args, $chunk, shift @_;
76 # maybe $msg and ... stuff
82 sub is_same_sql_bind {
83 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref;
86 my $same_sql = eq_sql($sql1, $sql2);
87 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
89 # call Test::Builder::ok
90 my $tb = $tb || __PACKAGE__->builder;
91 my $ret = $tb->ok($same_sql && $same_bind, $msg);
95 _sql_differ_diag($sql1, $sql2);
98 _bind_differ_diag($bind_ref1, $bind_ref2);
101 # pass ok() result further
106 my ($sql1, $sql2, $msg) = @_;
109 my $same_sql = eq_sql($sql1, $sql2);
111 # call Test::Builder::ok
112 my $tb = $tb || __PACKAGE__->builder;
113 my $ret = $tb->ok($same_sql, $msg);
117 _sql_differ_diag($sql1, $sql2);
120 # pass ok() result further
125 my ($bind_ref1, $bind_ref2, $msg) = @_;
128 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
130 # call Test::Builder::ok
131 my $tb = $tb || __PACKAGE__->builder;
132 my $ret = $tb->ok($same_bind, $msg);
136 _bind_differ_diag($bind_ref1, $bind_ref2);
139 # pass ok() result further
145 # if we save the instance, we will end up with $VARx references
146 # no time to figure out how to avoid this (Deepcopy is *not* an option)
147 require Data::Dumper;
148 Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
149 ->Values([@_])->Dump;
153 my $tb = $tb || __PACKAGE__->builder;
154 $tb->diag("Search term:\n" . &dumper);
157 sub _sql_differ_diag {
158 my $sql1 = shift || '';
159 my $sql2 = shift || '';
161 my $tb = $tb || __PACKAGE__->builder;
163 if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
164 my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
165 $_ = $sqlat->format($_) for ($sql1, $sql2);
168 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
169 "SQL expressions differ\n"
172 ."\nmismatch around\n$sql_differ\n"
176 sub _bind_differ_diag {
177 my ($bind_ref1, $bind_ref2) = @_;
179 my $tb = $tb || __PACKAGE__->builder;
180 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
181 "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
186 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
188 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
192 sub eq_bind { goto &Test::Deep::eq_deeply };
195 my ($sql1, $sql2) = @_;
198 my $tree1 = $sqlat->parse($sql1);
199 my $tree2 = $sqlat->parse($sql2);
202 return 1 if _eq_sql($tree1, $tree2);
206 my ($left, $right) = @_;
208 # one is defined the other not
209 if ((defined $left) xor (defined $right)) {
210 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
214 # one is undefined, then so is the other
215 elsif (not defined $left) {
220 elsif (@$left == 0 and @$right == 0) {
225 if (@$left == 0 or @$right == 0) {
226 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
230 # one is a list, the other is an op with a list
231 elsif (ref $left->[0] xor ref $right->[0]) {
232 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
233 { ref $_ ? $sqlat->unparse($_) : $_ }
234 ($left->[0], $right->[0], $left, $right)
240 elsif (ref $left->[0]) {
241 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
242 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
243 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
245 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
246 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
257 # unroll parenthesis if possible/allowed
258 unless ($parenthesis_significant) {
259 $sqlat->_parenthesis_unroll($_) for $left, $right;
262 # unroll ASC order by's
263 unless ($order_by_asc_significant) {
264 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
267 if ($left->[0] ne $right->[0]) {
268 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
269 $sqlat->unparse($left),
270 $sqlat->unparse($right)
275 # literals have a different arg-sig
276 elsif ($left->[0] eq '-LITERAL') {
277 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
278 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
279 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
280 $sql_differ = "[$l] != [$r]\n" if not $eq;
284 # if operators are identical, compare operands
286 my $eq = _eq_sql($left->[1], $right->[1]);
287 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
293 sub parse { $sqlat->parse(@_) }
301 SQL::Abstract::Test - Helper function for testing SQL::Abstract
307 use SQL::Abstract::Test import => [qw/
308 is_same_sql_bind is_same_sql is_same_bind
309 eq_sql_bind eq_sql eq_bind
312 my ($sql, @bind) = SQL::Abstract->new->select(%args);
314 is_same_sql_bind($given_sql, \@given_bind,
315 $expected_sql, \@expected_bind, $test_msg);
317 is_same_sql($given_sql, $expected_sql, $test_msg);
318 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
320 my $is_same = eq_sql_bind($given_sql, \@given_bind,
321 $expected_sql, \@expected_bind);
323 my $sql_same = eq_sql($given_sql, $expected_sql);
324 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
328 This module is only intended for authors of tests on
329 L<SQL::Abstract|SQL::Abstract> and related modules;
330 it exports functions for comparing two SQL statements
331 and their bound values.
333 The SQL comparison is performed on I<abstract syntax>,
334 ignoring differences in spaces or in levels of parentheses.
335 Therefore the tests will pass as long as the semantics
336 is preserved, even if the surface syntax has changed.
338 B<Disclaimer> : the semantic equivalence handling is pretty limited.
339 A lot of effort goes into distinguishing significant from
340 non-significant parenthesis, including AND/OR operator associativity.
341 Currently this module does not support commutativity and more
342 intelligent transformations like L<De Morgan's laws
343 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
345 For a good overview of what this test framework is currently capable of refer
350 =head2 is_same_sql_bind
353 $given_sql, \@given_bind,
354 $expected_sql, \@expected_bind,
359 \[$given_sql, @given_bind],
360 \[$expected_sql, @expected_bind],
366 $expected_sql, \@expected_bind,
370 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
371 as shown in the examples above and passing the arguments to L</eq_sql> and
372 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
373 C<$test_msg> as message.
374 If the test fails, a detailed diagnostic is printed.
384 Compares given and expected SQL statements via L</eq_sql>, and calls
385 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
386 If the test fails, a detailed diagnostic is printed.
396 Compares given and expected bind values via L</eq_bind>, and calls
397 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
398 If the test fails, a detailed diagnostic is printed.
402 my $is_same = eq_sql_bind(
403 $given_sql, \@given_bind,
404 $expected_sql, \@expected_bind,
407 my $is_same = eq_sql_bind(
408 \[$given_sql, @given_bind],
409 \[$expected_sql, @expected_bind],
412 my $is_same = eq_sql_bind(
414 $expected_sql, \@expected_bind,
417 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
418 L</eq_bind>, returning their combined result.
422 my $is_same = eq_sql($given_sql, $expected_sql);
424 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
425 but it just returns a boolean value and does not print diagnostics or talk to
426 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
427 will contain the SQL portion where a difference was encountered; this is useful
428 for printing diagnostics.
432 my $is_same = eq_sql(\@given_bind, \@expected_bind);
434 Compares two lists of bind values, taking into account the fact that some of
435 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
436 L</is_same_bind>, but it just returns a boolean value and does not print
437 diagnostics or talk to L<Test::Builder>.
439 =head1 GLOBAL VARIABLES
441 =head2 $case_sensitive
443 If true, SQL comparisons will be case-sensitive. Default is false;
445 =head2 $parenthesis_significant
447 If true, SQL comparison will preserve and report difference in nested
448 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
451 =head2 $order_by_asc_significant
453 If true SQL comparison will consider C<ORDER BY foo ASC> and
454 C<ORDER BY foo> to be different. Default is false;
458 When L</eq_sql> returns false, the global variable
459 C<$sql_differ> contains the SQL portion
460 where a difference was encountered.
464 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
468 Laurent Dami <laurent.dami AT etat geneve ch>
470 Norbert Buchmuller <norbi@nix.hu>
472 Peter Rabbitson <ribasushi@cpan.org>
474 =head1 COPYRIGHT AND LICENSE
476 Copyright 2008 by Laurent Dami.
478 This library is free software; you can redistribute it and/or modify
479 it under the same terms as Perl itself.