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:
273 # a single non-mathop child with a single PAREN grandchild which
274 # would indicate mathop ( nonmathop ( ... ) )
275 # or a single non-mathop with a single LITERAL ( nonmathop ? )
279 @{$child->[1][0][1]} == 1
281 $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
283 $child->[1][0][0] !~ SQL::Abstract::Tree::_math_op_re
286 $child->[1][0][1][0][0] eq 'PAREN'
288 $child->[1][0][1][0][0] eq 'LITERAL'
291 push @children, $child->[1][0];
296 # otherwise no more mucking for this pass
298 push @children, $child;
302 $ast->[1] = \@children;
308 sub parse { $sqlat->parse(@_) }
316 SQL::Abstract::Test - Helper function for testing SQL::Abstract
322 use SQL::Abstract::Test import => [qw/
323 is_same_sql_bind is_same_sql is_same_bind
324 eq_sql_bind eq_sql eq_bind
327 my ($sql, @bind) = SQL::Abstract->new->select(%args);
329 is_same_sql_bind($given_sql, \@given_bind,
330 $expected_sql, \@expected_bind, $test_msg);
332 is_same_sql($given_sql, $expected_sql, $test_msg);
333 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
335 my $is_same = eq_sql_bind($given_sql, \@given_bind,
336 $expected_sql, \@expected_bind);
338 my $sql_same = eq_sql($given_sql, $expected_sql);
339 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
343 This module is only intended for authors of tests on
344 L<SQL::Abstract|SQL::Abstract> and related modules;
345 it exports functions for comparing two SQL statements
346 and their bound values.
348 The SQL comparison is performed on I<abstract syntax>,
349 ignoring differences in spaces or in levels of parentheses.
350 Therefore the tests will pass as long as the semantics
351 is preserved, even if the surface syntax has changed.
353 B<Disclaimer> : the semantic equivalence handling is pretty limited.
354 A lot of effort goes into distinguishing significant from
355 non-significant parenthesis, including AND/OR operator associativity.
356 Currently this module does not support commutativity and more
357 intelligent transformations like Morgan laws, etc.
359 For a good overview of what this test framework is capable of refer
364 =head2 is_same_sql_bind
366 is_same_sql_bind($given_sql, \@given_bind,
367 $expected_sql, \@expected_bind, $test_msg);
369 Compares given and expected pairs of C<($sql, \@bind)>, and calls
370 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
371 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
372 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
373 L</is_same_bind>) that needs to be imported.
377 is_same_sql($given_sql, $expected_sql, $test_msg);
379 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
380 the result, with C<$test_msg> as message. If the test fails, a detailed
381 diagnostic is printed. For clients which use L<Test::More>, this is the one of
382 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
383 that needs to be imported.
387 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
389 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
390 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
391 is printed. For clients which use L<Test::More>, this is the one of the three
392 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
397 my $is_same = eq_sql_bind($given_sql, \@given_bind,
398 $expected_sql, \@expected_bind);
400 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
401 L</is_same_sql_bind>, but it just returns a boolean value and does not print
402 diagnostics or talk to L<Test::Builder>.
406 my $is_same = eq_sql($given_sql, $expected_sql);
408 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
409 but it just returns a boolean value and does not print diagnostics or talk to
410 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
411 will contain the SQL portion where a difference was encountered; this is useful
412 for printing diagnostics.
416 my $is_same = eq_sql(\@given_bind, \@expected_bind);
418 Compares two lists of bind values, taking into account the fact that some of
419 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
420 L</is_same_bind>, but it just returns a boolean value and does not print
421 diagnostics or talk to L<Test::Builder>.
423 =head1 GLOBAL VARIABLES
425 =head2 $case_sensitive
427 If true, SQL comparisons will be case-sensitive. Default is false;
429 =head2 $parenthesis_significant
431 If true, SQL comparison will preserve and report difference in nested
432 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
436 When L</eq_sql> returns false, the global variable
437 C<$sql_differ> contains the SQL portion
438 where a difference was encountered.
443 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
447 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
449 Norbert Buchmuller <norbi@nix.hu>
451 Peter Rabbitson <ribasushi@cpan.org>
453 =head1 COPYRIGHT AND LICENSE
455 Copyright 2008 by Laurent Dami.
457 This library is free software; you can redistribute it and/or modify
458 it under the same terms as Perl itself.