1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw/Test::Builder::Module Exporter/;
8 use SQL::Abstract::Tree;
10 our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
11 &eq_sql_bind &eq_sql &eq_bind
12 $case_sensitive $sql_differ/;
14 my $sqlat = SQL::Abstract::Tree->new;
16 our $case_sensitive = 0;
17 our $parenthesis_significant = 0;
18 our $sql_differ; # keeps track of differing portion between SQLs
19 our $tb = __PACKAGE__->builder;
21 sub is_same_sql_bind {
22 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
25 my $same_sql = eq_sql($sql1, $sql2);
26 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
28 # call Test::Builder::ok
29 my $ret = $tb->ok($same_sql && $same_bind, $msg);
33 _sql_differ_diag($sql1, $sql2);
36 _bind_differ_diag($bind_ref1, $bind_ref2);
39 # pass ok() result further
44 my ($sql1, $sql2, $msg) = @_;
47 my $same_sql = eq_sql($sql1, $sql2);
49 # call Test::Builder::ok
50 my $ret = $tb->ok($same_sql, $msg);
54 _sql_differ_diag($sql1, $sql2);
57 # pass ok() result further
62 my ($bind_ref1, $bind_ref2, $msg) = @_;
65 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
67 # call Test::Builder::ok
68 my $ret = $tb->ok($same_bind, $msg);
72 _bind_differ_diag($bind_ref1, $bind_ref2);
75 # pass ok() result further
79 sub _sql_differ_diag {
80 my ($sql1, $sql2) = @_;
82 $tb->diag("SQL expressions differ\n"
85 ."differing in :\n$sql_differ\n"
89 sub _bind_differ_diag {
90 my ($bind_ref1, $bind_ref2) = @_;
92 $tb->diag("BIND values differ\n"
93 ." got: " . Dumper($bind_ref1)
94 ."expected: " . Dumper($bind_ref2)
99 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
101 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
106 my ($bind_ref1, $bind_ref2) = @_;
108 local $Data::Dumper::Useqq = 1;
109 local $Data::Dumper::Sortkeys = 1;
111 return Dumper($bind_ref1) eq Dumper($bind_ref2);
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 if ( $left->[0] ne $right->[0] ) {
183 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
184 $sqlat->unparse($left),
185 $sqlat->unparse($right)
190 # literals have a different arg-sig
191 elsif ($left->[0] eq '-LITERAL') {
192 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
193 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
194 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
195 $sql_differ = "[$l] != [$r]\n" if not $eq;
199 # if operators are identical, compare operands
201 my $eq = _eq_sql($left->[1], $right->[1]);
202 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
208 sub parse { $sqlat->parse(@_) }
216 SQL::Abstract::Test - Helper function for testing SQL::Abstract
222 use SQL::Abstract::Test import => [qw/
223 is_same_sql_bind is_same_sql is_same_bind
224 eq_sql_bind eq_sql eq_bind
227 my ($sql, @bind) = SQL::Abstract->new->select(%args);
229 is_same_sql_bind($given_sql, \@given_bind,
230 $expected_sql, \@expected_bind, $test_msg);
232 is_same_sql($given_sql, $expected_sql, $test_msg);
233 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
235 my $is_same = eq_sql_bind($given_sql, \@given_bind,
236 $expected_sql, \@expected_bind);
238 my $sql_same = eq_sql($given_sql, $expected_sql);
239 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
243 This module is only intended for authors of tests on
244 L<SQL::Abstract|SQL::Abstract> and related modules;
245 it exports functions for comparing two SQL statements
246 and their bound values.
248 The SQL comparison is performed on I<abstract syntax>,
249 ignoring differences in spaces or in levels of parentheses.
250 Therefore the tests will pass as long as the semantics
251 is preserved, even if the surface syntax has changed.
253 B<Disclaimer> : the semantic equivalence handling is pretty limited.
254 A lot of effort goes into distinguishing significant from
255 non-significant parenthesis, including AND/OR operator associativity.
256 Currently this module does not support commutativity and more
257 intelligent transformations like Morgan laws, etc.
259 For a good overview of what this test framework is capable of refer
264 =head2 is_same_sql_bind
266 is_same_sql_bind($given_sql, \@given_bind,
267 $expected_sql, \@expected_bind, $test_msg);
269 Compares given and expected pairs of C<($sql, \@bind)>, and calls
270 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
271 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
272 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
273 L</is_same_bind>) that needs to be imported.
277 is_same_sql($given_sql, $expected_sql, $test_msg);
279 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
280 the result, with C<$test_msg> as message. If the test fails, a detailed
281 diagnostic is printed. For clients which use L<Test::More>, this is the one of
282 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
283 that needs to be imported.
287 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
289 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
290 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
291 is printed. For clients which use L<Test::More>, this is the one of the three
292 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
297 my $is_same = eq_sql_bind($given_sql, \@given_bind,
298 $expected_sql, \@expected_bind);
300 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
301 L</is_same_sql_bind>, but it just returns a boolean value and does not print
302 diagnostics or talk to L<Test::Builder>.
306 my $is_same = eq_sql($given_sql, $expected_sql);
308 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
309 but it just returns a boolean value and does not print diagnostics or talk to
310 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
311 will contain the SQL portion where a difference was encountered; this is useful
312 for printing diagnostics.
316 my $is_same = eq_sql(\@given_bind, \@expected_bind);
318 Compares two lists of bind values, taking into account the fact that some of
319 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
320 L</is_same_bind>, but it just returns a boolean value and does not print
321 diagnostics or talk to L<Test::Builder>.
323 =head1 GLOBAL VARIABLES
325 =head2 $case_sensitive
327 If true, SQL comparisons will be case-sensitive. Default is false;
329 =head2 $parenthesis_significant
331 If true, SQL comparison will preserve and report difference in nested
332 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
337 When L</eq_sql> returns false, the global variable
338 C<$sql_differ> contains the SQL portion
339 where a difference was encountered.
344 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
348 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
350 Norbert Buchmuller <norbi@nix.hu>
352 Peter Rabbitson <ribasushi@cpan.org>
354 =head1 COPYRIGHT AND LICENSE
356 Copyright 2008 by Laurent Dami.
358 This library is free software; you can redistribute it and/or modify
359 it under the same terms as Perl itself.