1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw/Test::Builder::Module Exporter/;
9 use SQL::Abstract::Tree;
11 our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
12 &eq_sql_bind &eq_sql &eq_bind
13 $case_sensitive $sql_differ/;
15 my $sqlat = SQL::Abstract::Tree->new;
17 our $case_sensitive = 0;
18 our $parenthesis_significant = 0;
19 our $order_by_asc_significant = 0;
21 our $sql_differ; # keeps track of differing portion between SQLs
22 our $tb = __PACKAGE__->builder;
24 sub is_same_sql_bind {
25 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
28 my $same_sql = eq_sql($sql1, $sql2);
29 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
31 # call Test::Builder::ok
32 my $ret = $tb->ok($same_sql && $same_bind, $msg);
36 _sql_differ_diag($sql1, $sql2);
39 _bind_differ_diag($bind_ref1, $bind_ref2);
42 # pass ok() result further
47 my ($sql1, $sql2, $msg) = @_;
50 my $same_sql = eq_sql($sql1, $sql2);
52 # call Test::Builder::ok
53 my $ret = $tb->ok($same_sql, $msg);
57 _sql_differ_diag($sql1, $sql2);
60 # pass ok() result further
65 my ($bind_ref1, $bind_ref2, $msg) = @_;
68 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
70 # call Test::Builder::ok
71 my $ret = $tb->ok($same_bind, $msg);
75 _bind_differ_diag($bind_ref1, $bind_ref2);
78 # pass ok() result further
82 sub _sql_differ_diag {
83 my ($sql1, $sql2) = @_;
85 $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
86 "SQL expressions differ\n"
89 ."differing in :\n$sql_differ\n"
93 sub _bind_differ_diag {
94 my ($bind_ref1, $bind_ref2) = @_;
96 local $Data::Dumper::Maxdepth;
98 $tb->${\( $tb->in_todo ? 'note' : 'diag')} (
99 "BIND values differ\n"
100 ." got: " . Dumper($bind_ref1)
101 ."expected: " . Dumper($bind_ref2)
106 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
108 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
112 sub eq_bind { goto &Test::Deep::eq_deeply };
115 my ($sql1, $sql2) = @_;
118 my $tree1 = $sqlat->parse($sql1);
119 my $tree2 = $sqlat->parse($sql2);
122 return 1 if _eq_sql($tree1, $tree2);
126 my ($left, $right) = @_;
128 # one is defined the other not
129 if ( (defined $left) xor (defined $right) ) {
130 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
134 # one is undefined, then so is the other
135 elsif (not defined $left) {
140 elsif (@$left == 0 and @$right == 0) {
145 if (@$left == 0 or @$right == 0) {
146 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
150 # one is a list, the other is an op with a list
151 elsif (ref $left->[0] xor ref $right->[0]) {
152 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
153 { ref $_ ? $sqlat->unparse ($_) : $_ }
154 ($left->[0], $right->[0], $left, $right)
160 elsif (ref $left->[0]) {
161 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
162 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
163 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
165 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
166 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
177 # unroll parenthesis if possible/allowed
178 unless ( $parenthesis_significant ) {
179 $sqlat->_parenthesis_unroll($_) for $left, $right;
182 # unroll ASC order by's
183 unless ($order_by_asc_significant) {
184 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
187 if ( $left->[0] ne $right->[0] ) {
188 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
189 $sqlat->unparse($left),
190 $sqlat->unparse($right)
195 # literals have a different arg-sig
196 elsif ($left->[0] eq '-LITERAL') {
197 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
198 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
199 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
200 $sql_differ = "[$l] != [$r]\n" if not $eq;
204 # if operators are identical, compare operands
206 my $eq = _eq_sql($left->[1], $right->[1]);
207 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
213 sub parse { $sqlat->parse(@_) }
221 SQL::Abstract::Test - Helper function for testing SQL::Abstract
227 use SQL::Abstract::Test import => [qw/
228 is_same_sql_bind is_same_sql is_same_bind
229 eq_sql_bind eq_sql eq_bind
232 my ($sql, @bind) = SQL::Abstract->new->select(%args);
234 is_same_sql_bind($given_sql, \@given_bind,
235 $expected_sql, \@expected_bind, $test_msg);
237 is_same_sql($given_sql, $expected_sql, $test_msg);
238 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
240 my $is_same = eq_sql_bind($given_sql, \@given_bind,
241 $expected_sql, \@expected_bind);
243 my $sql_same = eq_sql($given_sql, $expected_sql);
244 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
248 This module is only intended for authors of tests on
249 L<SQL::Abstract|SQL::Abstract> and related modules;
250 it exports functions for comparing two SQL statements
251 and their bound values.
253 The SQL comparison is performed on I<abstract syntax>,
254 ignoring differences in spaces or in levels of parentheses.
255 Therefore the tests will pass as long as the semantics
256 is preserved, even if the surface syntax has changed.
258 B<Disclaimer> : the semantic equivalence handling is pretty limited.
259 A lot of effort goes into distinguishing significant from
260 non-significant parenthesis, including AND/OR operator associativity.
261 Currently this module does not support commutativity and more
262 intelligent transformations like Morgan laws, etc.
264 For a good overview of what this test framework is capable of refer
269 =head2 is_same_sql_bind
271 is_same_sql_bind($given_sql, \@given_bind,
272 $expected_sql, \@expected_bind, $test_msg);
274 Compares given and expected pairs of C<($sql, \@bind)>, and calls
275 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
276 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
277 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
278 L</is_same_bind>) that needs to be imported.
282 is_same_sql($given_sql, $expected_sql, $test_msg);
284 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
285 the result, with C<$test_msg> as message. If the test fails, a detailed
286 diagnostic is printed. For clients which use L<Test::More>, this is the one of
287 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
288 that needs to be imported.
292 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
294 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
295 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
296 is printed. For clients which use L<Test::More>, this is the one of the three
297 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
302 my $is_same = eq_sql_bind($given_sql, \@given_bind,
303 $expected_sql, \@expected_bind);
305 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
306 L</is_same_sql_bind>, but it just returns a boolean value and does not print
307 diagnostics or talk to L<Test::Builder>.
311 my $is_same = eq_sql($given_sql, $expected_sql);
313 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
314 but it just returns a boolean value and does not print diagnostics or talk to
315 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
316 will contain the SQL portion where a difference was encountered; this is useful
317 for printing diagnostics.
321 my $is_same = eq_sql(\@given_bind, \@expected_bind);
323 Compares two lists of bind values, taking into account the fact that some of
324 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
325 L</is_same_bind>, but it just returns a boolean value and does not print
326 diagnostics or talk to L<Test::Builder>.
328 =head1 GLOBAL VARIABLES
330 =head2 $case_sensitive
332 If true, SQL comparisons will be case-sensitive. Default is false;
334 =head2 $parenthesis_significant
336 If true, SQL comparison will preserve and report difference in nested
337 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
340 =head2 $order_by_asc_significant
342 If true SQL comparison will consider C<ORDER BY foo ASC> and
343 C<ORDER BY foo> to be different. Default is false;
347 When L</eq_sql> returns false, the global variable
348 C<$sql_differ> contains the SQL portion
349 where a difference was encountered.
354 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
358 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
360 Norbert Buchmuller <norbi@nix.hu>
362 Peter Rabbitson <ribasushi@cpan.org>
364 =head1 COPYRIGHT AND LICENSE
366 Copyright 2008 by Laurent Dami.
368 This library is free software; you can redistribute it and/or modify
369 it under the same terms as Perl itself.