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 $sql_differ; # keeps track of differing portion between SQLs
20 our $tb = __PACKAGE__->builder;
22 sub is_same_sql_bind {
23 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
26 my $same_sql = eq_sql($sql1, $sql2);
27 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
29 # call Test::Builder::ok
30 my $ret = $tb->ok($same_sql && $same_bind, $msg);
34 _sql_differ_diag($sql1, $sql2);
37 _bind_differ_diag($bind_ref1, $bind_ref2);
40 # pass ok() result further
45 my ($sql1, $sql2, $msg) = @_;
48 my $same_sql = eq_sql($sql1, $sql2);
50 # call Test::Builder::ok
51 my $ret = $tb->ok($same_sql, $msg);
55 _sql_differ_diag($sql1, $sql2);
58 # pass ok() result further
63 my ($bind_ref1, $bind_ref2, $msg) = @_;
66 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
68 # call Test::Builder::ok
69 my $ret = $tb->ok($same_bind, $msg);
73 _bind_differ_diag($bind_ref1, $bind_ref2);
76 # pass ok() result further
80 sub _sql_differ_diag {
81 my ($sql1, $sql2) = @_;
83 $tb->diag("SQL expressions differ\n"
86 ."differing in :\n$sql_differ\n"
90 sub _bind_differ_diag {
91 my ($bind_ref1, $bind_ref2) = @_;
93 $tb->diag("BIND values differ\n"
94 ." got: " . Dumper($bind_ref1)
95 ."expected: " . Dumper($bind_ref2)
100 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
102 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
106 sub eq_bind { goto &Test::Deep::eq_deeply };
109 my ($sql1, $sql2) = @_;
112 my $tree1 = $sqlat->parse($sql1);
113 my $tree2 = $sqlat->parse($sql2);
116 return 1 if _eq_sql($tree1, $tree2);
120 my ($left, $right) = @_;
122 # one is defined the other not
123 if ( (defined $left) xor (defined $right) ) {
124 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
128 # one is undefined, then so is the other
129 elsif (not defined $left) {
134 elsif (@$left == 0 and @$right == 0) {
139 if (@$left == 0 or @$right == 0) {
140 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
144 # one is a list, the other is an op with a list
145 elsif (ref $left->[0] xor ref $right->[0]) {
146 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
147 { ref $_ ? $sqlat->unparse ($_) : $_ }
148 ($left->[0], $right->[0], $left, $right)
154 elsif (ref $left->[0]) {
155 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
156 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
157 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
159 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
160 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
171 # unroll parenthesis if possible/allowed
172 unless ( $parenthesis_significant ) {
173 $sqlat->_parenthesis_unroll($_) for $left, $right;
176 if ( $left->[0] ne $right->[0] ) {
177 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
178 $sqlat->unparse($left),
179 $sqlat->unparse($right)
184 # literals have a different arg-sig
185 elsif ($left->[0] eq '-LITERAL') {
186 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
187 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
188 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
189 $sql_differ = "[$l] != [$r]\n" if not $eq;
193 # if operators are identical, compare operands
195 my $eq = _eq_sql($left->[1], $right->[1]);
196 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
202 sub parse { $sqlat->parse(@_) }
210 SQL::Abstract::Test - Helper function for testing SQL::Abstract
216 use SQL::Abstract::Test import => [qw/
217 is_same_sql_bind is_same_sql is_same_bind
218 eq_sql_bind eq_sql eq_bind
221 my ($sql, @bind) = SQL::Abstract->new->select(%args);
223 is_same_sql_bind($given_sql, \@given_bind,
224 $expected_sql, \@expected_bind, $test_msg);
226 is_same_sql($given_sql, $expected_sql, $test_msg);
227 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
229 my $is_same = eq_sql_bind($given_sql, \@given_bind,
230 $expected_sql, \@expected_bind);
232 my $sql_same = eq_sql($given_sql, $expected_sql);
233 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
237 This module is only intended for authors of tests on
238 L<SQL::Abstract|SQL::Abstract> and related modules;
239 it exports functions for comparing two SQL statements
240 and their bound values.
242 The SQL comparison is performed on I<abstract syntax>,
243 ignoring differences in spaces or in levels of parentheses.
244 Therefore the tests will pass as long as the semantics
245 is preserved, even if the surface syntax has changed.
247 B<Disclaimer> : the semantic equivalence handling is pretty limited.
248 A lot of effort goes into distinguishing significant from
249 non-significant parenthesis, including AND/OR operator associativity.
250 Currently this module does not support commutativity and more
251 intelligent transformations like Morgan laws, etc.
253 For a good overview of what this test framework is capable of refer
258 =head2 is_same_sql_bind
260 is_same_sql_bind($given_sql, \@given_bind,
261 $expected_sql, \@expected_bind, $test_msg);
263 Compares given and expected pairs of C<($sql, \@bind)>, and calls
264 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
265 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
266 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
267 L</is_same_bind>) that needs to be imported.
271 is_same_sql($given_sql, $expected_sql, $test_msg);
273 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
274 the result, with C<$test_msg> as message. If the test fails, a detailed
275 diagnostic is printed. For clients which use L<Test::More>, this is the one of
276 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
277 that needs to be imported.
281 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
283 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
284 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
285 is printed. For clients which use L<Test::More>, this is the one of the three
286 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
291 my $is_same = eq_sql_bind($given_sql, \@given_bind,
292 $expected_sql, \@expected_bind);
294 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
295 L</is_same_sql_bind>, but it just returns a boolean value and does not print
296 diagnostics or talk to L<Test::Builder>.
300 my $is_same = eq_sql($given_sql, $expected_sql);
302 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
303 but it just returns a boolean value and does not print diagnostics or talk to
304 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
305 will contain the SQL portion where a difference was encountered; this is useful
306 for printing diagnostics.
310 my $is_same = eq_sql(\@given_bind, \@expected_bind);
312 Compares two lists of bind values, taking into account the fact that some of
313 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
314 L</is_same_bind>, but it just returns a boolean value and does not print
315 diagnostics or talk to L<Test::Builder>.
317 =head1 GLOBAL VARIABLES
319 =head2 $case_sensitive
321 If true, SQL comparisons will be case-sensitive. Default is false;
323 =head2 $parenthesis_significant
325 If true, SQL comparison will preserve and report difference in nested
326 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
331 When L</eq_sql> returns false, the global variable
332 C<$sql_differ> contains the SQL portion
333 where a difference was encountered.
338 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
342 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
344 Norbert Buchmuller <norbi@nix.hu>
346 Peter Rabbitson <ribasushi@cpan.org>
348 =head1 COPYRIGHT AND LICENSE
350 Copyright 2008 by Laurent Dami.
352 This library is free software; you can redistribute it and/or modify
353 it under the same terms as Perl itself.