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 our $case_sensitive = 0;
15 our $parenthesis_significant = 0;
16 our $sql_differ; # keeps track of differing portion between SQLs
17 our $tb = __PACKAGE__->builder;
19 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
20 my @unrollable_ops = (
28 sub is_same_sql_bind {
29 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
32 my $same_sql = eq_sql($sql1, $sql2);
33 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
35 # call Test::Builder::ok
36 my $ret = $tb->ok($same_sql && $same_bind, $msg);
40 _sql_differ_diag($sql1, $sql2);
43 _bind_differ_diag($bind_ref1, $bind_ref2);
46 # pass ok() result further
51 my ($sql1, $sql2, $msg) = @_;
54 my $same_sql = eq_sql($sql1, $sql2);
56 # call Test::Builder::ok
57 my $ret = $tb->ok($same_sql, $msg);
61 _sql_differ_diag($sql1, $sql2);
64 # pass ok() result further
69 my ($bind_ref1, $bind_ref2, $msg) = @_;
72 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
74 # call Test::Builder::ok
75 my $ret = $tb->ok($same_bind, $msg);
79 _bind_differ_diag($bind_ref1, $bind_ref2);
82 # pass ok() result further
86 sub _sql_differ_diag {
87 my ($sql1, $sql2) = @_;
89 $tb->diag("SQL expressions differ\n"
92 ."differing in :\n$sql_differ\n"
96 sub _bind_differ_diag {
97 my ($bind_ref1, $bind_ref2) = @_;
99 $tb->diag("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);
113 my ($bind_ref1, $bind_ref2) = @_;
115 local $Data::Dumper::Useqq = 1;
116 local $Data::Dumper::Sortkeys = 1;
118 return Dumper($bind_ref1) eq Dumper($bind_ref2);
122 my ($sql1, $sql2) = @_;
125 my $tree1 = parse($sql1);
126 my $tree2 = parse($sql2);
128 return 1 if _eq_sql($tree1, $tree2);
132 my ($left, $right) = @_;
134 # one is defined the other not
135 if ( (defined $left) xor (defined $right) ) {
138 # one is undefined, then so is the other
139 elsif (not defined $left) {
142 # one is a list, the other is an op with a list
143 elsif (ref $left->[0] xor ref $right->[0]) {
144 $sql_differ = sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) );
147 # one is a list, so is the other
148 elsif (ref $left->[0]) {
149 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
150 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
154 # both are an op-list combo
157 # unroll parenthesis if possible/allowed
158 _parenthesis_unroll ($_) for ($left, $right);
160 # if operators are different
161 if ( $left->[0] ne $right->[0] ) {
162 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
167 # elsif operators are identical, compare operands
169 if ($left->[0] eq 'LITERAL' ) { # unary
170 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
171 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
172 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
173 $sql_differ = "[$l] != [$r]\n" if not $eq;
177 my $eq = _eq_sql($left->[1], $right->[1]);
178 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq;
185 sub _parenthesis_unroll {
188 return if $parenthesis_significant;
189 return unless (ref $ast and ref $ast->[1]);
196 for my $child (@{$ast->[1]}) {
197 if (not ref $child or not $child->[0] eq 'PAREN') {
198 push @children, $child;
202 # unroll nested parenthesis
203 while ($child->[1][0][0] eq 'PAREN') {
204 $child = $child->[1][0];
208 # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
210 ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
212 $child->[1][0][0] eq $ast->[0]
214 push @children, @{$child->[1][0][1]};
218 # if the parent operator explcitly allows it nuke the parenthesis
219 elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
220 push @children, $child->[1][0];
224 # only one LITERAL element in the parenthesis
226 @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
228 push @children, $child->[1][0];
232 # only one element in the parenthesis which is a binary op with two LITERAL sub-children
236 grep { $child->[1][0][0] =~ /^ $_ $/xi } (SQL::Abstract::Tree::_binary_op_keywords())
238 $child->[1][0][1][0][0] eq 'LITERAL'
240 $child->[1][0][1][1][0] eq 'LITERAL'
242 push @children, $child->[1][0];
246 # otherwise no more mucking for this pass
248 push @children, $child;
252 $ast->[1] = \@children;
258 sub parse { goto &SQL::Abstract::Tree::parse }
260 sub unparse { goto &SQL::Abstract::Tree::unparse }
270 SQL::Abstract::Test - Helper function for testing SQL::Abstract
276 use SQL::Abstract::Test import => [qw/
277 is_same_sql_bind is_same_sql is_same_bind
278 eq_sql_bind eq_sql eq_bind
281 my ($sql, @bind) = SQL::Abstract->new->select(%args);
283 is_same_sql_bind($given_sql, \@given_bind,
284 $expected_sql, \@expected_bind, $test_msg);
286 is_same_sql($given_sql, $expected_sql, $test_msg);
287 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
289 my $is_same = eq_sql_bind($given_sql, \@given_bind,
290 $expected_sql, \@expected_bind);
292 my $sql_same = eq_sql($given_sql, $expected_sql);
293 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
297 This module is only intended for authors of tests on
298 L<SQL::Abstract|SQL::Abstract> and related modules;
299 it exports functions for comparing two SQL statements
300 and their bound values.
302 The SQL comparison is performed on I<abstract syntax>,
303 ignoring differences in spaces or in levels of parentheses.
304 Therefore the tests will pass as long as the semantics
305 is preserved, even if the surface syntax has changed.
307 B<Disclaimer> : the semantic equivalence handling is pretty limited.
308 A lot of effort goes into distinguishing significant from
309 non-significant parenthesis, including AND/OR operator associativity.
310 Currently this module does not support commutativity and more
311 intelligent transformations like Morgan laws, etc.
313 For a good overview of what this test framework is capable of refer
318 =head2 is_same_sql_bind
320 is_same_sql_bind($given_sql, \@given_bind,
321 $expected_sql, \@expected_bind, $test_msg);
323 Compares given and expected pairs of C<($sql, \@bind)>, and calls
324 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
325 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
326 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
327 L</is_same_bind>) that needs to be imported.
331 is_same_sql($given_sql, $expected_sql, $test_msg);
333 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
334 the result, with C<$test_msg> as message. If the test fails, a detailed
335 diagnostic is printed. For clients which use L<Test::More>, this is the one of
336 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
337 that needs to be imported.
341 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
343 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
344 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
345 is printed. For clients which use L<Test::More>, this is the one of the three
346 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
351 my $is_same = eq_sql_bind($given_sql, \@given_bind,
352 $expected_sql, \@expected_bind);
354 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
355 L</is_same_sql_bind>, but it just returns a boolean value and does not print
356 diagnostics or talk to L<Test::Builder>.
360 my $is_same = eq_sql($given_sql, $expected_sql);
362 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
363 but it just returns a boolean value and does not print diagnostics or talk to
364 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
365 will contain the SQL portion where a difference was encountered; this is useful
366 for printing diagnostics.
370 my $is_same = eq_sql(\@given_bind, \@expected_bind);
372 Compares two lists of bind values, taking into account the fact that some of
373 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
374 L</is_same_bind>, but it just returns a boolean value and does not print
375 diagnostics or talk to L<Test::Builder>.
377 =head1 GLOBAL VARIABLES
379 =head2 $case_sensitive
381 If true, SQL comparisons will be case-sensitive. Default is false;
383 =head2 $parenthesis_significant
385 If true, SQL comparison will preserve and report difference in nested
386 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
390 When L</eq_sql> returns false, the global variable
391 C<$sql_differ> contains the SQL portion
392 where a difference was encountered.
397 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
401 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
403 Norbert Buchmuller <norbi@nix.hu>
405 Peter Rabbitson <ribasushi@cpan.org>
407 =head1 COPYRIGHT AND LICENSE
409 Copyright 2008 by Laurent Dami.
411 This library is free software; you can redistribute it and/or modify
412 it under the same terms as Perl itself.