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 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
22 my @unrollable_ops = (
29 my $unrollable_ops_re = join ' | ', @unrollable_ops;
30 $unrollable_ops_re = qr/$unrollable_ops_re/xi;
32 sub is_same_sql_bind {
33 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
36 my $same_sql = eq_sql($sql1, $sql2);
37 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
39 # call Test::Builder::ok
40 my $ret = $tb->ok($same_sql && $same_bind, $msg);
44 _sql_differ_diag($sql1, $sql2);
47 _bind_differ_diag($bind_ref1, $bind_ref2);
50 # pass ok() result further
55 my ($sql1, $sql2, $msg) = @_;
58 my $same_sql = eq_sql($sql1, $sql2);
60 # call Test::Builder::ok
61 my $ret = $tb->ok($same_sql, $msg);
65 _sql_differ_diag($sql1, $sql2);
68 # pass ok() result further
73 my ($bind_ref1, $bind_ref2, $msg) = @_;
76 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
78 # call Test::Builder::ok
79 my $ret = $tb->ok($same_bind, $msg);
83 _bind_differ_diag($bind_ref1, $bind_ref2);
86 # pass ok() result further
90 sub _sql_differ_diag {
91 my ($sql1, $sql2) = @_;
93 $tb->diag("SQL expressions differ\n"
96 ."differing in :\n$sql_differ\n"
100 sub _bind_differ_diag {
101 my ($bind_ref1, $bind_ref2) = @_;
103 $tb->diag("BIND values differ\n"
104 ." got: " . Dumper($bind_ref1)
105 ."expected: " . Dumper($bind_ref2)
110 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
112 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
117 my ($bind_ref1, $bind_ref2) = @_;
119 local $Data::Dumper::Useqq = 1;
120 local $Data::Dumper::Sortkeys = 1;
122 return Dumper($bind_ref1) eq Dumper($bind_ref2);
126 my ($sql1, $sql2) = @_;
129 my $tree1 = $sqlat->parse($sql1);
130 my $tree2 = $sqlat->parse($sql2);
132 return 1 if _eq_sql($tree1, $tree2);
136 my ($left, $right) = @_;
138 # one is defined the other not
139 if ( (defined $left) xor (defined $right) ) {
142 # one is undefined, then so is the other
143 elsif (not defined $left) {
146 # different amount of elements
147 elsif (@$left != @$right) {
148 $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
151 # one is empty - so is the other
152 elsif (@$left == 0) {
155 # one is a list, the other is an op with a list
156 elsif (ref $left->[0] xor ref $right->[0]) {
157 $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
160 # one is a list, so is the other
161 elsif (ref $left->[0]) {
162 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
163 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
167 # both are an op-list combo
170 # unroll parenthesis if possible/allowed
171 _parenthesis_unroll ($_) for ($left, $right);
173 # if operators are different
174 if ( $left->[0] ne $right->[0] ) {
175 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
176 $sqlat->unparse($left),
177 $sqlat->unparse($right);
180 # elsif operators are identical, compare operands
182 if ($left->[0] eq 'LITERAL' ) { # unary
183 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
184 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
185 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
186 $sql_differ = "[$l] != [$r]\n" if not $eq;
190 my $eq = _eq_sql($left->[1], $right->[1]);
191 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
198 sub _parenthesis_unroll {
201 return if $parenthesis_significant;
202 return unless (ref $ast and ref $ast->[1]);
209 for my $child (@{$ast->[1]}) {
210 # the current node in this loop is *always* a PAREN
211 if (not ref $child or not $child->[0] eq 'PAREN') {
212 push @children, $child;
216 # unroll nested parenthesis
217 while ( @{$child->[1]} && $child->[1][0][0] eq 'PAREN') {
218 $child = $child->[1][0];
222 # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
224 ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
226 $child->[1][0][0] eq $ast->[0]
228 push @children, @{$child->[1][0][1]};
232 # if the parent operator explcitly allows it nuke the parenthesis
233 elsif ( $ast->[0] =~ $unrollable_ops_re ) {
234 push @children, $child->[1][0];
238 # only *ONE* LITERAL element
240 @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
242 push @children, $child->[1][0];
246 # only one element in the parenthesis which is a binary op
247 # and has exactly two grandchildren
248 # the only time when we can *not* unroll this is when both
249 # the parent and the child are mathops (in which case we'll
250 # break precedence) or when the child is BETWEEN (special
255 $child->[1][0][0] =~ SQL::Abstract::Tree::_binary_op_re()
257 $child->[1][0][0] ne 'BETWEEN'
259 @{$child->[1][0][1]} == 2
262 $child->[1][0][0] =~ SQL::Abstract::Tree::_math_op_re()
264 $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
267 push @children, $child->[1][0];
271 # a function binds tighter than a mathop - see if our ancestor is a
272 # mathop, and our content is a single non-mathop child with a single
273 # PAREN grandchild which would indicate mathop ( nonmathop ( ... ) )
277 @{$child->[1][0][1]} == 1
279 $child->[1][0][1][0][0] eq 'PAREN'
281 $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
283 $child->[1][0][0] !~ SQL::Abstract::Tree::_math_op_re
285 push @children, $child->[1][0];
290 # otherwise no more mucking for this pass
292 push @children, $child;
296 $ast->[1] = \@children;
302 sub parse { $sqlat->parse(@_) }
310 SQL::Abstract::Test - Helper function for testing SQL::Abstract
316 use SQL::Abstract::Test import => [qw/
317 is_same_sql_bind is_same_sql is_same_bind
318 eq_sql_bind eq_sql eq_bind
321 my ($sql, @bind) = SQL::Abstract->new->select(%args);
323 is_same_sql_bind($given_sql, \@given_bind,
324 $expected_sql, \@expected_bind, $test_msg);
326 is_same_sql($given_sql, $expected_sql, $test_msg);
327 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
329 my $is_same = eq_sql_bind($given_sql, \@given_bind,
330 $expected_sql, \@expected_bind);
332 my $sql_same = eq_sql($given_sql, $expected_sql);
333 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
337 This module is only intended for authors of tests on
338 L<SQL::Abstract|SQL::Abstract> and related modules;
339 it exports functions for comparing two SQL statements
340 and their bound values.
342 The SQL comparison is performed on I<abstract syntax>,
343 ignoring differences in spaces or in levels of parentheses.
344 Therefore the tests will pass as long as the semantics
345 is preserved, even if the surface syntax has changed.
347 B<Disclaimer> : the semantic equivalence handling is pretty limited.
348 A lot of effort goes into distinguishing significant from
349 non-significant parenthesis, including AND/OR operator associativity.
350 Currently this module does not support commutativity and more
351 intelligent transformations like Morgan laws, etc.
353 For a good overview of what this test framework is capable of refer
358 =head2 is_same_sql_bind
360 is_same_sql_bind($given_sql, \@given_bind,
361 $expected_sql, \@expected_bind, $test_msg);
363 Compares given and expected pairs of C<($sql, \@bind)>, and calls
364 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
365 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
366 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
367 L</is_same_bind>) that needs to be imported.
371 is_same_sql($given_sql, $expected_sql, $test_msg);
373 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
374 the result, with C<$test_msg> as message. If the test fails, a detailed
375 diagnostic is printed. For clients which use L<Test::More>, this is the one of
376 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
377 that needs to be imported.
381 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
383 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
384 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
385 is printed. For clients which use L<Test::More>, this is the one of the three
386 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
391 my $is_same = eq_sql_bind($given_sql, \@given_bind,
392 $expected_sql, \@expected_bind);
394 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
395 L</is_same_sql_bind>, but it just returns a boolean value and does not print
396 diagnostics or talk to L<Test::Builder>.
400 my $is_same = eq_sql($given_sql, $expected_sql);
402 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
403 but it just returns a boolean value and does not print diagnostics or talk to
404 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
405 will contain the SQL portion where a difference was encountered; this is useful
406 for printing diagnostics.
410 my $is_same = eq_sql(\@given_bind, \@expected_bind);
412 Compares two lists of bind values, taking into account the fact that some of
413 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
414 L</is_same_bind>, but it just returns a boolean value and does not print
415 diagnostics or talk to L<Test::Builder>.
417 =head1 GLOBAL VARIABLES
419 =head2 $case_sensitive
421 If true, SQL comparisons will be case-sensitive. Default is false;
423 =head2 $parenthesis_significant
425 If true, SQL comparison will preserve and report difference in nested
426 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
430 When L</eq_sql> returns false, the global variable
431 C<$sql_differ> contains the SQL portion
432 where a difference was encountered.
437 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
441 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
443 Norbert Buchmuller <norbi@nix.hu>
445 Peter Rabbitson <ribasushi@cpan.org>
447 =head1 COPYRIGHT AND LICENSE
449 Copyright 2008 by Laurent Dami.
451 This library is free software; you can redistribute it and/or modify
452 it under the same terms as Perl itself.