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 or placeholder element
240 @{$child->[1]} == 1 && (
241 $child->[1][0][0] eq 'LITERAL'
243 $child->[1][0][0] eq 'PLACEHOLDER'
246 push @children, $child->[1][0];
250 # only one element in the parenthesis which is a binary op
251 # and has exactly two grandchildren
252 # the only time when we can *not* unroll this is when both
253 # the parent and the child are mathops (in which case we'll
254 # break precedence) or when the child is BETWEEN (special
259 $child->[1][0][0] =~ SQL::Abstract::Tree::_binary_op_re()
261 $child->[1][0][0] ne 'BETWEEN'
263 @{$child->[1][0][1]} == 2
266 $child->[1][0][0] =~ SQL::Abstract::Tree::_math_op_re()
268 $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
271 push @children, $child->[1][0];
275 # a function binds tighter than a mathop - see if our ancestor is a
276 # mathop, and our content is:
277 # a single non-mathop child with a single PAREN grandchild which
278 # would indicate mathop ( nonmathop ( ... ) )
279 # or a single non-mathop with a single LITERAL ( nonmathop foo )
280 # or a single non-mathop with a single PLACEHOLDER ( nonmathop ? )
284 @{$child->[1][0][1]} == 1
286 $ast->[0] =~ SQL::Abstract::Tree::_math_op_re()
288 $child->[1][0][0] !~ SQL::Abstract::Tree::_math_op_re
291 $child->[1][0][1][0][0] eq 'PAREN'
293 $child->[1][0][1][0][0] eq 'LITERAL'
295 $child->[1][0][1][0][0] eq 'PLACEHOLDER'
298 push @children, $child->[1][0];
303 # otherwise no more mucking for this pass
305 push @children, $child;
309 $ast->[1] = \@children;
315 sub parse { $sqlat->parse(@_) }
323 SQL::Abstract::Test - Helper function for testing SQL::Abstract
329 use SQL::Abstract::Test import => [qw/
330 is_same_sql_bind is_same_sql is_same_bind
331 eq_sql_bind eq_sql eq_bind
334 my ($sql, @bind) = SQL::Abstract->new->select(%args);
336 is_same_sql_bind($given_sql, \@given_bind,
337 $expected_sql, \@expected_bind, $test_msg);
339 is_same_sql($given_sql, $expected_sql, $test_msg);
340 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
342 my $is_same = eq_sql_bind($given_sql, \@given_bind,
343 $expected_sql, \@expected_bind);
345 my $sql_same = eq_sql($given_sql, $expected_sql);
346 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
350 This module is only intended for authors of tests on
351 L<SQL::Abstract|SQL::Abstract> and related modules;
352 it exports functions for comparing two SQL statements
353 and their bound values.
355 The SQL comparison is performed on I<abstract syntax>,
356 ignoring differences in spaces or in levels of parentheses.
357 Therefore the tests will pass as long as the semantics
358 is preserved, even if the surface syntax has changed.
360 B<Disclaimer> : the semantic equivalence handling is pretty limited.
361 A lot of effort goes into distinguishing significant from
362 non-significant parenthesis, including AND/OR operator associativity.
363 Currently this module does not support commutativity and more
364 intelligent transformations like Morgan laws, etc.
366 For a good overview of what this test framework is capable of refer
371 =head2 is_same_sql_bind
373 is_same_sql_bind($given_sql, \@given_bind,
374 $expected_sql, \@expected_bind, $test_msg);
376 Compares given and expected pairs of C<($sql, \@bind)>, and calls
377 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
378 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
379 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
380 L</is_same_bind>) that needs to be imported.
384 is_same_sql($given_sql, $expected_sql, $test_msg);
386 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
387 the result, with C<$test_msg> as message. If the test fails, a detailed
388 diagnostic is printed. For clients which use L<Test::More>, this is the one of
389 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
390 that needs to be imported.
394 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
396 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
397 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
398 is printed. For clients which use L<Test::More>, this is the one of the three
399 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
404 my $is_same = eq_sql_bind($given_sql, \@given_bind,
405 $expected_sql, \@expected_bind);
407 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
408 L</is_same_sql_bind>, but it just returns a boolean value and does not print
409 diagnostics or talk to L<Test::Builder>.
413 my $is_same = eq_sql($given_sql, $expected_sql);
415 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
416 but it just returns a boolean value and does not print diagnostics or talk to
417 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
418 will contain the SQL portion where a difference was encountered; this is useful
419 for printing diagnostics.
423 my $is_same = eq_sql(\@given_bind, \@expected_bind);
425 Compares two lists of bind values, taking into account the fact that some of
426 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
427 L</is_same_bind>, but it just returns a boolean value and does not print
428 diagnostics or talk to L<Test::Builder>.
430 =head1 GLOBAL VARIABLES
432 =head2 $case_sensitive
434 If true, SQL comparisons will be case-sensitive. Default is false;
436 =head2 $parenthesis_significant
438 If true, SQL comparison will preserve and report difference in nested
439 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
443 When L</eq_sql> returns false, the global variable
444 C<$sql_differ> contains the SQL portion
445 where a difference was encountered.
450 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
454 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
456 Norbert Buchmuller <norbi@nix.hu>
458 Peter Rabbitson <ribasushi@cpan.org>
460 =head1 COPYRIGHT AND LICENSE
462 Copyright 2008 by Laurent Dami.
464 This library is free software; you can redistribute it and/or modify
465 it under the same terms as Perl itself.