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 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 = __PACKAGE__->builder;
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 $ret = $tb->ok($same_sql && $same_bind, $msg);
94 _sql_differ_diag($sql1, $sql2);
97 _bind_differ_diag($bind_ref1, $bind_ref2);
100 # pass ok() result further
105 my ($sql1, $sql2, $msg) = @_;
108 my $same_sql = eq_sql($sql1, $sql2);
110 # call Test::Builder::ok
111 my $ret = $tb->ok($same_sql, $msg);
115 _sql_differ_diag($sql1, $sql2);
118 # pass ok() result further
123 my ($bind_ref1, $bind_ref2, $msg) = @_;
126 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
128 # call Test::Builder::ok
129 my $ret = $tb->ok($same_bind, $msg);
133 _bind_differ_diag($bind_ref1, $bind_ref2);
136 # pass ok() result further
142 # if we save the instance, we will end up with $VARx references
143 # no time to figure out how to avoid this (Deepcopy is *not* an option)
144 require Data::Dumper;
145 Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
146 ->Values([@_])->Dump;
150 $tb->diag("Search term:\n" . &dumper);
153 sub _sql_differ_diag {
154 my $sql1 = shift || '';
155 my $sql2 = shift || '';
157 if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
158 my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
159 $_ = $sqlat->format($_) for ($sql1, $sql2);
162 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
163 "SQL expressions differ\n"
166 ."\nmismatch around\n$sql_differ\n"
170 sub _bind_differ_diag {
171 my ($bind_ref1, $bind_ref2) = @_;
173 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
174 "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
179 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
181 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
185 sub eq_bind { goto &Test::Deep::eq_deeply };
188 my ($sql1, $sql2) = @_;
191 my $tree1 = $sqlat->parse($sql1);
192 my $tree2 = $sqlat->parse($sql2);
195 return 1 if _eq_sql($tree1, $tree2);
199 my ($left, $right) = @_;
201 # one is defined the other not
202 if ((defined $left) xor (defined $right)) {
203 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
207 # one is undefined, then so is the other
208 elsif (not defined $left) {
213 elsif (@$left == 0 and @$right == 0) {
218 if (@$left == 0 or @$right == 0) {
219 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
223 # one is a list, the other is an op with a list
224 elsif (ref $left->[0] xor ref $right->[0]) {
225 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
226 { ref $_ ? $sqlat->unparse($_) : $_ }
227 ($left->[0], $right->[0], $left, $right)
233 elsif (ref $left->[0]) {
234 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
235 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
236 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
238 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
239 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
250 # unroll parenthesis if possible/allowed
251 unless ($parenthesis_significant) {
252 $sqlat->_parenthesis_unroll($_) for $left, $right;
255 # unroll ASC order by's
256 unless ($order_by_asc_significant) {
257 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
260 if ($left->[0] ne $right->[0]) {
261 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
262 $sqlat->unparse($left),
263 $sqlat->unparse($right)
268 # literals have a different arg-sig
269 elsif ($left->[0] eq '-LITERAL') {
270 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
271 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
272 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
273 $sql_differ = "[$l] != [$r]\n" if not $eq;
277 # if operators are identical, compare operands
279 my $eq = _eq_sql($left->[1], $right->[1]);
280 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
286 sub parse { $sqlat->parse(@_) }
294 SQL::Abstract::Test - Helper function for testing SQL::Abstract
300 use SQL::Abstract::Test import => [qw/
301 is_same_sql_bind is_same_sql is_same_bind
302 eq_sql_bind eq_sql eq_bind
305 my ($sql, @bind) = SQL::Abstract->new->select(%args);
307 is_same_sql_bind($given_sql, \@given_bind,
308 $expected_sql, \@expected_bind, $test_msg);
310 is_same_sql($given_sql, $expected_sql, $test_msg);
311 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
313 my $is_same = eq_sql_bind($given_sql, \@given_bind,
314 $expected_sql, \@expected_bind);
316 my $sql_same = eq_sql($given_sql, $expected_sql);
317 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
321 This module is only intended for authors of tests on
322 L<SQL::Abstract|SQL::Abstract> and related modules;
323 it exports functions for comparing two SQL statements
324 and their bound values.
326 The SQL comparison is performed on I<abstract syntax>,
327 ignoring differences in spaces or in levels of parentheses.
328 Therefore the tests will pass as long as the semantics
329 is preserved, even if the surface syntax has changed.
331 B<Disclaimer> : the semantic equivalence handling is pretty limited.
332 A lot of effort goes into distinguishing significant from
333 non-significant parenthesis, including AND/OR operator associativity.
334 Currently this module does not support commutativity and more
335 intelligent transformations like L<De Morgan's laws
336 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
338 For a good overview of what this test framework is currently capable of refer
343 =head2 is_same_sql_bind
346 $given_sql, \@given_bind,
347 $expected_sql, \@expected_bind,
352 \[$given_sql, @given_bind],
353 \[$expected_sql, @expected_bind],
359 $expected_sql, \@expected_bind,
363 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
364 as shown in the examples above and passing the arguments to L</eq_sql> and
365 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
366 C<$test_msg> as message.
367 If the test fails, a detailed diagnostic is printed.
377 Compares given and expected SQL statements via L</eq_sql>, and calls
378 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
379 If the test fails, a detailed diagnostic is printed.
389 Compares given and expected bind values via L</eq_bind>, and calls
390 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
391 If the test fails, a detailed diagnostic is printed.
395 my $is_same = eq_sql_bind(
396 $given_sql, \@given_bind,
397 $expected_sql, \@expected_bind,
400 my $is_same = eq_sql_bind(
401 \[$given_sql, @given_bind],
402 \[$expected_sql, @expected_bind],
405 my $is_same = eq_sql_bind(
407 $expected_sql, \@expected_bind,
410 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
411 L</eq_bind>, returning their combined result.
415 my $is_same = eq_sql($given_sql, $expected_sql);
417 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
418 but it just returns a boolean value and does not print diagnostics or talk to
419 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
420 will contain the SQL portion where a difference was encountered; this is useful
421 for printing diagnostics.
425 my $is_same = eq_sql(\@given_bind, \@expected_bind);
427 Compares two lists of bind values, taking into account the fact that some of
428 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
429 L</is_same_bind>, but it just returns a boolean value and does not print
430 diagnostics or talk to L<Test::Builder>.
432 =head1 GLOBAL VARIABLES
434 =head2 $case_sensitive
436 If true, SQL comparisons will be case-sensitive. Default is false;
438 =head2 $parenthesis_significant
440 If true, SQL comparison will preserve and report difference in nested
441 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
444 =head2 $order_by_asc_significant
446 If true SQL comparison will consider C<ORDER BY foo ASC> and
447 C<ORDER BY foo> to be different. Default is false;
451 When L</eq_sql> returns false, the global variable
452 C<$sql_differ> contains the SQL portion
453 where a difference was encountered.
457 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
461 Laurent Dami <laurent.dami AT etat geneve ch>
463 Norbert Buchmuller <norbi@nix.hu>
465 Peter Rabbitson <ribasushi@cpan.org>
467 =head1 COPYRIGHT AND LICENSE
469 Copyright 2008 by Laurent Dami.
471 This library is free software; you can redistribute it and/or modify
472 it under the same terms as Perl itself.