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->diag("SQL expressions differ\n"
88 ."differing in :\n$sql_differ\n"
92 sub _bind_differ_diag {
93 my ($bind_ref1, $bind_ref2) = @_;
95 $tb->diag("BIND values differ\n"
96 ." got: " . Dumper($bind_ref1)
97 ."expected: " . Dumper($bind_ref2)
102 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
104 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
108 sub eq_bind { goto &Test::Deep::eq_deeply };
111 my ($sql1, $sql2) = @_;
114 my $tree1 = $sqlat->parse($sql1);
115 my $tree2 = $sqlat->parse($sql2);
118 return 1 if _eq_sql($tree1, $tree2);
122 my ($left, $right) = @_;
124 # one is defined the other not
125 if ( (defined $left) xor (defined $right) ) {
126 $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
130 # one is undefined, then so is the other
131 elsif (not defined $left) {
136 elsif (@$left == 0 and @$right == 0) {
141 if (@$left == 0 or @$right == 0) {
142 $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
146 # one is a list, the other is an op with a list
147 elsif (ref $left->[0] xor ref $right->[0]) {
148 $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
149 { ref $_ ? $sqlat->unparse ($_) : $_ }
150 ($left->[0], $right->[0], $left, $right)
156 elsif (ref $left->[0]) {
157 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
158 if (not _eq_sql ($left->[$i], $right->[$i]) ) {
159 if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
161 $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
162 $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
173 # unroll parenthesis if possible/allowed
174 unless ( $parenthesis_significant ) {
175 $sqlat->_parenthesis_unroll($_) for $left, $right;
178 # unroll ASC order by's
179 unless ($order_by_asc_significant) {
180 $sqlat->_strip_asc_from_order_by($_) for $left, $right;
183 if ( $left->[0] ne $right->[0] ) {
184 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
185 $sqlat->unparse($left),
186 $sqlat->unparse($right)
191 # literals have a different arg-sig
192 elsif ($left->[0] eq '-LITERAL') {
193 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
194 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
195 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
196 $sql_differ = "[$l] != [$r]\n" if not $eq;
200 # if operators are identical, compare operands
202 my $eq = _eq_sql($left->[1], $right->[1]);
203 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
209 sub parse { $sqlat->parse(@_) }
217 SQL::Abstract::Test - Helper function for testing SQL::Abstract
223 use SQL::Abstract::Test import => [qw/
224 is_same_sql_bind is_same_sql is_same_bind
225 eq_sql_bind eq_sql eq_bind
228 my ($sql, @bind) = SQL::Abstract->new->select(%args);
230 is_same_sql_bind($given_sql, \@given_bind,
231 $expected_sql, \@expected_bind, $test_msg);
233 is_same_sql($given_sql, $expected_sql, $test_msg);
234 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
236 my $is_same = eq_sql_bind($given_sql, \@given_bind,
237 $expected_sql, \@expected_bind);
239 my $sql_same = eq_sql($given_sql, $expected_sql);
240 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
244 This module is only intended for authors of tests on
245 L<SQL::Abstract|SQL::Abstract> and related modules;
246 it exports functions for comparing two SQL statements
247 and their bound values.
249 The SQL comparison is performed on I<abstract syntax>,
250 ignoring differences in spaces or in levels of parentheses.
251 Therefore the tests will pass as long as the semantics
252 is preserved, even if the surface syntax has changed.
254 B<Disclaimer> : the semantic equivalence handling is pretty limited.
255 A lot of effort goes into distinguishing significant from
256 non-significant parenthesis, including AND/OR operator associativity.
257 Currently this module does not support commutativity and more
258 intelligent transformations like Morgan laws, etc.
260 For a good overview of what this test framework is capable of refer
265 =head2 is_same_sql_bind
267 is_same_sql_bind($given_sql, \@given_bind,
268 $expected_sql, \@expected_bind, $test_msg);
270 Compares given and expected pairs of C<($sql, \@bind)>, and calls
271 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
272 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
273 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
274 L</is_same_bind>) that needs to be imported.
278 is_same_sql($given_sql, $expected_sql, $test_msg);
280 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
281 the result, with C<$test_msg> as message. If the test fails, a detailed
282 diagnostic is printed. For clients which use L<Test::More>, this is the one of
283 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
284 that needs to be imported.
288 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
290 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
291 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
292 is printed. For clients which use L<Test::More>, this is the one of the three
293 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
298 my $is_same = eq_sql_bind($given_sql, \@given_bind,
299 $expected_sql, \@expected_bind);
301 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
302 L</is_same_sql_bind>, but it just returns a boolean value and does not print
303 diagnostics or talk to L<Test::Builder>.
307 my $is_same = eq_sql($given_sql, $expected_sql);
309 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
310 but it just returns a boolean value and does not print diagnostics or talk to
311 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
312 will contain the SQL portion where a difference was encountered; this is useful
313 for printing diagnostics.
317 my $is_same = eq_sql(\@given_bind, \@expected_bind);
319 Compares two lists of bind values, taking into account the fact that some of
320 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
321 L</is_same_bind>, but it just returns a boolean value and does not print
322 diagnostics or talk to L<Test::Builder>.
324 =head1 GLOBAL VARIABLES
326 =head2 $case_sensitive
328 If true, SQL comparisons will be case-sensitive. Default is false;
330 =head2 $parenthesis_significant
332 If true, SQL comparison will preserve and report difference in nested
333 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
336 =head2 $order_by_asc_significant
338 If true SQL comparison will consider C<ORDER BY foo ASC> and
339 C<ORDER BY foo> to be different. Default is false;
343 When L</eq_sql> returns false, the global variable
344 C<$sql_differ> contains the SQL portion
345 where a difference was encountered.
350 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
354 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
356 Norbert Buchmuller <norbi@nix.hu>
358 Peter Rabbitson <ribasushi@cpan.org>
360 =head1 COPYRIGHT AND LICENSE
362 Copyright 2008 by Laurent Dami.
364 This library is free software; you can redistribute it and/or modify
365 it under the same terms as Perl itself.