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);
121 return 1 if _eq_sql($tree1, $tree2);
125 my ($left, $right) = @_;
127 # one is defined the other not
128 if ( (defined $left) xor (defined $right) ) {
131 # one is undefined, then so is the other
132 elsif (not defined $left) {
135 # different amount of elements
136 elsif (@$left != @$right) {
139 # one is empty - so is the other
140 elsif (@$left == 0) {
143 # one is a list, the other is an op with a list
144 elsif (ref $left->[0] xor ref $right->[0]) {
145 $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
148 # one is a list, so is the other
149 elsif (ref $left->[0]) {
150 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
151 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
155 # both are an op-list combo
158 # unroll parenthesis if possible/allowed
159 $parenthesis_significant || $sqlat->_parenthesis_unroll($_) for $left, $right;
161 # if operators are different
162 if ( $left->[0] ne $right->[0] ) {
163 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
164 $sqlat->unparse($left),
165 $sqlat->unparse($right);
168 # elsif operators are identical, compare operands
170 if ($left->[0] eq 'LITERAL' ) { # unary
171 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
172 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
173 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
174 $sql_differ = "[$l] != [$r]\n" if not $eq;
178 my $eq = _eq_sql($left->[1], $right->[1]);
179 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
186 sub parse { $sqlat->parse(@_) }
194 SQL::Abstract::Test - Helper function for testing SQL::Abstract
200 use SQL::Abstract::Test import => [qw/
201 is_same_sql_bind is_same_sql is_same_bind
202 eq_sql_bind eq_sql eq_bind
205 my ($sql, @bind) = SQL::Abstract->new->select(%args);
207 is_same_sql_bind($given_sql, \@given_bind,
208 $expected_sql, \@expected_bind, $test_msg);
210 is_same_sql($given_sql, $expected_sql, $test_msg);
211 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
213 my $is_same = eq_sql_bind($given_sql, \@given_bind,
214 $expected_sql, \@expected_bind);
216 my $sql_same = eq_sql($given_sql, $expected_sql);
217 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
221 This module is only intended for authors of tests on
222 L<SQL::Abstract|SQL::Abstract> and related modules;
223 it exports functions for comparing two SQL statements
224 and their bound values.
226 The SQL comparison is performed on I<abstract syntax>,
227 ignoring differences in spaces or in levels of parentheses.
228 Therefore the tests will pass as long as the semantics
229 is preserved, even if the surface syntax has changed.
231 B<Disclaimer> : the semantic equivalence handling is pretty limited.
232 A lot of effort goes into distinguishing significant from
233 non-significant parenthesis, including AND/OR operator associativity.
234 Currently this module does not support commutativity and more
235 intelligent transformations like Morgan laws, etc.
237 For a good overview of what this test framework is capable of refer
242 =head2 is_same_sql_bind
244 is_same_sql_bind($given_sql, \@given_bind,
245 $expected_sql, \@expected_bind, $test_msg);
247 Compares given and expected pairs of C<($sql, \@bind)>, and calls
248 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
249 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
250 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
251 L</is_same_bind>) that needs to be imported.
255 is_same_sql($given_sql, $expected_sql, $test_msg);
257 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
258 the result, with C<$test_msg> as message. If the test fails, a detailed
259 diagnostic is printed. For clients which use L<Test::More>, this is the one of
260 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
261 that needs to be imported.
265 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
267 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
268 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
269 is printed. For clients which use L<Test::More>, this is the one of the three
270 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
275 my $is_same = eq_sql_bind($given_sql, \@given_bind,
276 $expected_sql, \@expected_bind);
278 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
279 L</is_same_sql_bind>, but it just returns a boolean value and does not print
280 diagnostics or talk to L<Test::Builder>.
284 my $is_same = eq_sql($given_sql, $expected_sql);
286 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
287 but it just returns a boolean value and does not print diagnostics or talk to
288 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
289 will contain the SQL portion where a difference was encountered; this is useful
290 for printing diagnostics.
294 my $is_same = eq_sql(\@given_bind, \@expected_bind);
296 Compares two lists of bind values, taking into account the fact that some of
297 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
298 L</is_same_bind>, but it just returns a boolean value and does not print
299 diagnostics or talk to L<Test::Builder>.
301 =head1 GLOBAL VARIABLES
303 =head2 $case_sensitive
305 If true, SQL comparisons will be case-sensitive. Default is false;
307 =head2 $parenthesis_significant
309 If true, SQL comparison will preserve and report difference in nested
310 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
315 When L</eq_sql> returns false, the global variable
316 C<$sql_differ> contains the SQL portion
317 where a difference was encountered.
322 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
326 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
328 Norbert Buchmuller <norbi@nix.hu>
330 Peter Rabbitson <ribasushi@cpan.org>
332 =head1 COPYRIGHT AND LICENSE
334 Copyright 2008 by Laurent Dami.
336 This library is free software; you can redistribute it and/or modify
337 it under the same terms as Perl itself.