1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw/Test::Builder::Module Exporter/;
9 use Test::Deep qw(eq_deeply);
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 our $case_sensitive = 0;
16 our $sql_differ; # keeps track of differing portion between SQLs
17 our $tb = __PACKAGE__->builder;
19 # Parser states for _recurse_parse()
20 use constant PARSE_IN_EXPR => 1;
21 use constant PARSE_IN_PARENS => 2;
22 use constant PARSE_TOP_LEVEL => 3;
24 # These SQL keywords always signal end of the current expression (except inside
25 # of a parenthesized subexpression).
26 # Format: A list of strings that will be compiled to extended syntax (ie.
27 # /.../x) regexes, without capturing parentheses. They will be automatically
28 # anchored to word boundaries to match the whole token).
29 my @expression_terminator_sql_keywords = (
34 (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
35 (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
52 # All of these keywords allow their parameters to be wrapped in parenthesis without changing any semantics
53 my @unrollable_sql_keywords = (
61 my $tokenizer_re_str = join('|',
62 map { '\b' . $_ . '\b' }
63 @expression_terminator_sql_keywords, 'AND', 'OR'
66 my $tokenizer_re = qr/
78 my $unrollable_re_str = join ('|', map { $_ } @unrollable_sql_keywords);
79 my $unrollable_re = qr/^ (?: $unrollable_re_str ) $/ix;
82 sub is_same_sql_bind {
83 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
86 my $same_sql = eq_sql($sql1, $sql2);
87 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
89 # call Test::Builder::ok
90 my $ret = $tb->ok($same_sql && $same_bind, $msg);
94 _sql_differ_diag($sql1, $sql2);
97 _bind_differ_diag($bind_ref1, $bind_ref2);
100 # pass ok() result further
105 my ($sql1, $sql2, $msg) = @_;
108 my $same_sql = eq_sql($sql1, $sql2);
110 # call Test::Builder::ok
111 my $ret = $tb->ok($same_sql, $msg);
115 _sql_differ_diag($sql1, $sql2);
118 # pass ok() result further
123 my ($bind_ref1, $bind_ref2, $msg) = @_;
126 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
128 # call Test::Builder::ok
129 my $ret = $tb->ok($same_bind, $msg);
133 _bind_differ_diag($bind_ref1, $bind_ref2);
136 # pass ok() result further
140 sub _sql_differ_diag {
141 my ($sql1, $sql2) = @_;
143 $tb->diag("SQL expressions differ\n"
146 ."differing in :\n$sql_differ\n"
150 sub _bind_differ_diag {
151 my ($bind_ref1, $bind_ref2) = @_;
153 $tb->diag("BIND values differ\n"
154 ." got: " . Dumper($bind_ref1)
155 ."expected: " . Dumper($bind_ref2)
160 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
162 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
167 my ($bind_ref1, $bind_ref2) = @_;
169 return eq_deeply($bind_ref1, $bind_ref2);
173 my ($sql1, $sql2) = @_;
176 my $tree1 = parse($sql1);
177 my $tree2 = parse($sql2);
179 return 1 if _eq_sql($tree1, $tree2);
183 my ($left, $right) = @_;
185 # one is defined the other not
186 if ( (defined $left) xor (defined $right) ) {
189 # one is undefined, then so is the other
190 elsif (not defined $left) {
193 # one is a list, the other is an op with a list
194 elsif (ref $left->[0] xor ref $right->[0]) {
195 $sql_differ = sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) );
198 # one is a list, so is the other
199 elsif (ref $left->[0]) {
200 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
201 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
205 # both are an op-list combo
208 for ($left, $right) {
210 next unless (ref $_->[1]);
212 # unroll parenthesis in an elaborate loop
219 for my $child (@{$_->[1]}) {
220 if (not ref $child or not $child->[0] eq 'PAREN') {
221 push @children, $child;
225 # unroll nested parenthesis
226 while ($child->[1][0][0] eq 'PAREN') {
227 $child = $child->[1][0];
231 # if the parens are wrapped around an AND/OR matching the parent AND/OR - open the parens up and merge the list
233 ( $_->[0] eq 'AND' or $_->[0] eq 'OR')
235 $child->[1][0][0] eq $_->[0]
237 push @children, @{$child->[1][0][1]};
241 # if the parent operator explcitly allows it, or if parents are wrapped around an expression just nuke them
242 elsif ( $child->[1][0][0] eq 'EXPR' or $_->[0] =~ $unrollable_re ) {
243 push @children, $child->[1][0];
247 # otherwise no more mucking
249 push @children, $child;
253 $_->[1] = \@children;
257 # if operators are different
258 if ($left->[0] ne $right->[0]) {
259 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
264 # elsif operators are identical, compare operands
266 if ($left->[0] eq 'EXPR' ) { # unary operator
267 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
268 (my $r = " $right->[1] ") =~ s/\s+/ /g;
269 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
270 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
274 my $eq = _eq_sql($left->[1], $right->[1]);
275 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq;
286 # tokenize string, and remove all optional whitespace
288 foreach my $token (split $tokenizer_re, $s) {
290 $token =~ s/\s+([^\w\s])/$1/g;
291 $token =~ s/([^\w\s])\s+/$1/g;
292 push @$tokens, $token if $token !~ /^$/;
295 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
300 my ($tokens, $state) = @_;
303 while (1) { # left-associative parsing
305 my $lookahead = $tokens->[0];
306 if ( not defined($lookahead)
308 ($state == PARSE_IN_PARENS && $lookahead eq ')')
310 ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords) )
314 return ($state == PARSE_TOP_LEVEL
320 my $token = shift @$tokens;
322 # nested expression in ()
324 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
325 $token = shift @$tokens or croak "missing ')'";
326 $token eq ')' or croak "unexpected token : $token";
327 $left = $left ? [@$left, [PAREN => [$right] ]]
328 : [PAREN => [$right] ];
331 elsif ($token =~ /^ (?: OR | AND ) $/xi ) {
333 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
335 # Merge chunks if logic matches
336 if (ref $right and $op eq $right->[0]) {
337 $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
340 $left = [$op => [$left, $right]];
343 # expression terminator keywords (as they start a new expression)
344 elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
346 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
347 $left = $left ? [@$left, [$op => [$right] ]]
348 : [ [$op => [$right] ] ];
352 $left = $left ? [@$left, [EXPR => $token] ]
353 : [ EXPR => $token ];
366 elsif (ref $tree->[0]) {
367 return join (" ", map { unparse ($_) } @$tree);
369 elsif ($tree->[0] eq 'EXPR') {
372 elsif ($tree->[0] eq 'PAREN') {
373 return sprintf '( %s )', join (" ", map {unparse($_)} @{$tree->[1]});
375 elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND') {
376 return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]});
379 return sprintf '%s %s', $tree->[0], unparse ($tree->[1]);
391 SQL::Abstract::Test - Helper function for testing SQL::Abstract
397 use SQL::Abstract::Test import => [qw/
398 is_same_sql_bind is_same_sql is_same_bind
399 eq_sql_bind eq_sql eq_bind
402 my ($sql, @bind) = SQL::Abstract->new->select(%args);
404 is_same_sql_bind($given_sql, \@given_bind,
405 $expected_sql, \@expected_bind, $test_msg);
407 is_same_sql($given_sql, $expected_sql, $test_msg);
408 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
410 my $is_same = eq_sql_bind($given_sql, \@given_bind,
411 $expected_sql, \@expected_bind);
413 my $sql_same = eq_sql($given_sql, $expected_sql);
414 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
418 This module is only intended for authors of tests on
419 L<SQL::Abstract|SQL::Abstract> and related modules;
420 it exports functions for comparing two SQL statements
421 and their bound values.
423 The SQL comparison is performed on I<abstract syntax>,
424 ignoring differences in spaces or in levels of parentheses.
425 Therefore the tests will pass as long as the semantics
426 is preserved, even if the surface syntax has changed.
428 B<Disclaimer> : this is only a half-cooked semantic equivalence;
429 parsing is simple-minded, and comparison of SQL abstract syntax trees
430 ignores commutativity or associativity of AND/OR operators, Morgan
435 =head2 is_same_sql_bind
437 is_same_sql_bind($given_sql, \@given_bind,
438 $expected_sql, \@expected_bind, $test_msg);
440 Compares given and expected pairs of C<($sql, \@bind)>, and calls
441 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
442 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
443 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
444 L</is_same_bind>) that needs to be imported.
448 is_same_sql($given_sql, $expected_sql, $test_msg);
450 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
451 the result, with C<$test_msg> as message. If the test fails, a detailed
452 diagnostic is printed. For clients which use L<Test::More>, this is the one of
453 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
454 that needs to be imported.
458 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
460 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
461 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
462 is printed. For clients which use L<Test::More>, this is the one of the three
463 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
468 my $is_same = eq_sql_bind($given_sql, \@given_bind,
469 $expected_sql, \@expected_bind);
471 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
472 L</is_same_sql_bind>, but it just returns a boolean value and does not print
473 diagnostics or talk to L<Test::Builder>.
477 my $is_same = eq_sql($given_sql, $expected_sql);
479 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
480 but it just returns a boolean value and does not print diagnostics or talk to
481 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
482 will contain the SQL portion where a difference was encountered; this is useful
483 for printing diagnostics.
487 my $is_same = eq_sql(\@given_bind, \@expected_bind);
489 Compares two lists of bind values, taking into account the fact that some of
490 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
491 L</is_same_bind>, but it just returns a boolean value and does not print
492 diagnostics or talk to L<Test::Builder>.
494 =head1 GLOBAL VARIABLES
496 =head2 $case_sensitive
498 If true, SQL comparisons will be case-sensitive. Default is false;
502 When L</eq_sql> returns false, the global variable
503 C<$sql_differ> contains the SQL portion
504 where a difference was encountered.
509 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
513 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
515 Norbert Buchmuller <norbi@nix.hu>
517 =head1 COPYRIGHT AND LICENSE
519 Copyright 2008 by Laurent Dami.
521 This library is free software; you can redistribute it and/or modify
522 it under the same terms as Perl itself.