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 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; # not documented, but someone might be overriding it anyway
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 $tb = $tb || __PACKAGE__->builder;
83 my $ret = $tb->ok($same_sql && $same_bind, $msg);
87 _sql_differ_diag($sql1, $sql2);
90 _bind_differ_diag($bind_ref1, $bind_ref2);
93 # pass ok() result further
98 my ($sql1, $sql2, $msg) = @_;
101 my $same_sql = eq_sql($sql1, $sql2);
103 # call Test::Builder::ok
104 my $tb = $tb || __PACKAGE__->builder;
105 my $ret = $tb->ok($same_sql, $msg);
109 _sql_differ_diag($sql1, $sql2);
112 # pass ok() result further
117 my ($bind_ref1, $bind_ref2, $msg) = @_;
120 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
122 # call Test::Builder::ok
123 my $tb = $tb || __PACKAGE__->builder;
124 my $ret = $tb->ok($same_bind, $msg);
128 _bind_differ_diag($bind_ref1, $bind_ref2);
131 # pass ok() result further
137 # if we save the instance, we will end up with $VARx references
138 # no time to figure out how to avoid this (Deepcopy is *not* an option)
139 require Data::Dumper;
140 Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)
141 ->Values([@_])->Dump;
145 my $tb = $tb || __PACKAGE__->builder;
146 $tb->diag("Search term:\n" . &dumper);
149 sub _sql_differ_diag {
150 my $sql1 = shift || '';
151 my $sql2 = shift || '';
153 my $tb = $tb || __PACKAGE__->builder;
155 if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) {
156 my $sqlat = SQL::Abstract::Tree->new(profile => $profile);
157 $_ = $sqlat->format($_) for ($sql1, $sql2);
160 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
161 "SQL expressions differ\n"
164 ."\nmismatch around\n$sql_differ\n"
168 sub _bind_differ_diag {
169 my ($bind_ref1, $bind_ref2) = @_;
171 my $tb = $tb || __PACKAGE__->builder;
172 $tb->${\($tb->in_todo ? 'note' : 'diag')} (
173 "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 })
178 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref;
180 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
184 sub eq_bind { goto &Test::Deep::eq_deeply };
187 my ($sql1, $sql2) = @_;
190 my $tree1 = $sqlat->parse($sql1);
191 my $tree2 = $sqlat->parse($sql2);
194 return 1 if _eq_sql($tree1, $tree2);
198 my ($left, $right) = @_;
200 # one is defined the other not
201 if ((defined $left) xor (defined $right)) {
202 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) );
206 # one is undefined, then so is the other
207 elsif (not defined $left) {
212 elsif (@$left == 0 and @$right == 0) {
217 if (@$left == 0 or @$right == 0) {
218 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) );
222 # one is a list, the other is an op with a list
223 elsif (ref $left->[0] xor ref $right->[0]) {
224 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
225 { ref $_ ? $sqlat->unparse($_) : $_ }
226 ($left->[0], $right->[0], $left, $right)
232 elsif (ref $left->[0]) {
233 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
234 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
235 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
237 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
238 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) );
249 # unroll parenthesis if possible/allowed
250 unless ($parenthesis_significant) {
251 $sqlat->_parenthesis_unroll($_) for $left, $right;
254 # unroll ASC order by's
255 unless ($order_by_asc_significant) {
256 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
259 if ($left->[0] ne $right->[0]) {
260 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
261 $sqlat->unparse($left),
262 $sqlat->unparse($right)
267 # literals have a different arg-sig
268 elsif ($left->[0] eq '-LITERAL') {
269 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
270 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
271 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
272 $sql_differ = "[$l] != [$r]\n" if not $eq;
276 # if operators are identical, compare operands
278 my $eq = _eq_sql($left->[1], $right->[1]);
279 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq;
285 sub parse { $sqlat->parse(@_) }
293 SQL::Abstract::Test - Helper function for testing SQL::Abstract
299 use SQL::Abstract::Test import => [qw/
300 is_same_sql_bind is_same_sql is_same_bind
301 eq_sql_bind eq_sql eq_bind
304 my ($sql, @bind) = SQL::Abstract->new->select(%args);
306 is_same_sql_bind($given_sql, \@given_bind,
307 $expected_sql, \@expected_bind, $test_msg);
309 is_same_sql($given_sql, $expected_sql, $test_msg);
310 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
312 my $is_same = eq_sql_bind($given_sql, \@given_bind,
313 $expected_sql, \@expected_bind);
315 my $sql_same = eq_sql($given_sql, $expected_sql);
316 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
320 This module is only intended for authors of tests on
321 L<SQL::Abstract|SQL::Abstract> and related modules;
322 it exports functions for comparing two SQL statements
323 and their bound values.
325 The SQL comparison is performed on I<abstract syntax>,
326 ignoring differences in spaces or in levels of parentheses.
327 Therefore the tests will pass as long as the semantics
328 is preserved, even if the surface syntax has changed.
330 B<Disclaimer> : the semantic equivalence handling is pretty limited.
331 A lot of effort goes into distinguishing significant from
332 non-significant parenthesis, including AND/OR operator associativity.
333 Currently this module does not support commutativity and more
334 intelligent transformations like L<De Morgan's laws
335 |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc.
337 For a good overview of what this test framework is currently capable of refer
342 =head2 is_same_sql_bind
345 $given_sql, \@given_bind,
346 $expected_sql, \@expected_bind,
351 \[$given_sql, @given_bind],
352 \[$expected_sql, @expected_bind],
358 $expected_sql, \@expected_bind,
362 Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_>
363 as shown in the examples above and passing the arguments to L</eq_sql> and
364 L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with
365 C<$test_msg> as message.
366 If the test fails, a detailed diagnostic is printed.
376 Compares given and expected SQL statements via L</eq_sql>, and calls
377 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
378 If the test fails, a detailed diagnostic is printed.
388 Compares given and expected bind values via L</eq_bind>, and calls
389 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
390 If the test fails, a detailed diagnostic is printed.
394 my $is_same = eq_sql_bind(
395 $given_sql, \@given_bind,
396 $expected_sql, \@expected_bind,
399 my $is_same = eq_sql_bind(
400 \[$given_sql, @given_bind],
401 \[$expected_sql, @expected_bind],
404 my $is_same = eq_sql_bind(
406 $expected_sql, \@expected_bind,
409 Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and
410 L</eq_bind>, returning their combined result.
414 my $is_same = eq_sql($given_sql, $expected_sql);
416 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
417 but it just returns a boolean value and does not print diagnostics or talk to
418 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
419 will contain the SQL portion where a difference was encountered; this is useful
420 for printing diagnostics.
424 my $is_same = eq_sql(\@given_bind, \@expected_bind);
426 Compares two lists of bind values, taking into account the fact that some of
427 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
428 L</is_same_bind>, but it just returns a boolean value and does not print
429 diagnostics or talk to L<Test::Builder>.
431 =head1 GLOBAL VARIABLES
433 =head2 $case_sensitive
435 If true, SQL comparisons will be case-sensitive. Default is false;
437 =head2 $parenthesis_significant
439 If true, SQL comparison will preserve and report difference in nested
440 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
443 =head2 $order_by_asc_significant
445 If true SQL comparison will consider C<ORDER BY foo ASC> and
446 C<ORDER BY foo> to be different. Default is false;
450 When L</eq_sql> returns false, the global variable
451 C<$sql_differ> contains the SQL portion
452 where a difference was encountered.
456 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
460 Laurent Dami <laurent.dami AT etat geneve ch>
462 Norbert Buchmuller <norbi@nix.hu>
464 Peter Rabbitson <ribasushi@cpan.org>
466 =head1 COPYRIGHT AND LICENSE
468 Copyright 2008 by Laurent Dami.
470 This library is free software; you can redistribute it and/or modify
471 it under the same terms as Perl itself.