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+ )?
41 '[\`\w]+ \s+ BETWEEN',
53 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
54 my @unrollable_sql_keywords = (
62 my $tokenizer_re_str = join('|',
63 map { '\b' . $_ . '\b' }
64 @expression_terminator_sql_keywords, 'AND', 'OR'
67 my $tokenizer_re = qr/
79 my $unrollable_re_str = join ('|', map { $_ } @unrollable_sql_keywords);
80 my $unrollable_re = qr/^ (?: $unrollable_re_str ) $/ix;
83 sub is_same_sql_bind {
84 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
87 my $same_sql = eq_sql($sql1, $sql2);
88 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
90 # call Test::Builder::ok
91 my $ret = $tb->ok($same_sql && $same_bind, $msg);
95 _sql_differ_diag($sql1, $sql2);
98 _bind_differ_diag($bind_ref1, $bind_ref2);
101 # pass ok() result further
106 my ($sql1, $sql2, $msg) = @_;
109 my $same_sql = eq_sql($sql1, $sql2);
111 # call Test::Builder::ok
112 my $ret = $tb->ok($same_sql, $msg);
116 _sql_differ_diag($sql1, $sql2);
119 # pass ok() result further
124 my ($bind_ref1, $bind_ref2, $msg) = @_;
127 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
129 # call Test::Builder::ok
130 my $ret = $tb->ok($same_bind, $msg);
134 _bind_differ_diag($bind_ref1, $bind_ref2);
137 # pass ok() result further
141 sub _sql_differ_diag {
142 my ($sql1, $sql2) = @_;
144 $tb->diag("SQL expressions differ\n"
147 ."differing in :\n$sql_differ\n"
151 sub _bind_differ_diag {
152 my ($bind_ref1, $bind_ref2) = @_;
154 $tb->diag("BIND values differ\n"
155 ." got: " . Dumper($bind_ref1)
156 ."expected: " . Dumper($bind_ref2)
161 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
163 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
168 my ($bind_ref1, $bind_ref2) = @_;
170 return eq_deeply($bind_ref1, $bind_ref2);
174 my ($sql1, $sql2) = @_;
177 my $tree1 = parse($sql1);
178 my $tree2 = parse($sql2);
180 return 1 if _eq_sql($tree1, $tree2);
184 my ($left, $right) = @_;
186 # one is defined the other not
187 if ( (defined $left) xor (defined $right) ) {
190 # one is undefined, then so is the other
191 elsif (not defined $left) {
194 # one is a list, the other is an op with a list
195 elsif (ref $left->[0] xor ref $right->[0]) {
196 $sql_differ = sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) );
199 # one is a list, so is the other
200 elsif (ref $left->[0]) {
201 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
202 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
206 # both are an op-list combo
209 for ($left, $right) {
211 next unless (ref $_->[1]);
213 # unroll parenthesis in an elaborate loop
220 for my $child (@{$_->[1]}) {
221 if (not ref $child or not $child->[0] eq 'PAREN') {
222 push @children, $child;
226 # unroll nested parenthesis
227 while ($child->[1][0][0] eq 'PAREN') {
228 $child = $child->[1][0];
232 # if the parens are wrapped around an AND/OR matching the parent AND/OR - open the parens up and merge the list
234 ( $_->[0] eq 'AND' or $_->[0] eq 'OR')
236 $child->[1][0][0] eq $_->[0]
238 push @children, @{$child->[1][0][1]};
242 # if the parent operator explcitly allows it, or if parents are wrapped around an expression just nuke them
243 elsif ( $child->[1][0][0] eq 'EXPR' or $_->[0] =~ $unrollable_re ) {
244 push @children, $child->[1][0];
248 # otherwise no more mucking
250 push @children, $child;
254 $_->[1] = \@children;
258 # if operators are different
259 if ($left->[0] ne $right->[0]) {
260 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
265 # elsif operators are identical, compare operands
267 if ($left->[0] eq 'EXPR' ) { # unary operator
268 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
269 (my $r = " $right->[1] ") =~ s/\s+/ /g;
270 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
271 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
275 my $eq = _eq_sql($left->[1], $right->[1]);
276 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq;
287 # tokenize string, and remove all optional whitespace
289 foreach my $token (split $tokenizer_re, $s) {
291 $token =~ s/\s+([^\w\s])/$1/g;
292 $token =~ s/([^\w\s])\s+/$1/g;
293 push @$tokens, $token if $token !~ /^$/;
296 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
301 my ($tokens, $state) = @_;
304 while (1) { # left-associative parsing
306 my $lookahead = $tokens->[0];
307 if ( not defined($lookahead)
309 ($state == PARSE_IN_PARENS && $lookahead eq ')')
311 ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords) )
315 return ($state == PARSE_TOP_LEVEL
321 my $token = shift @$tokens;
323 # nested expression in ()
325 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
326 $token = shift @$tokens or croak "missing ')'";
327 $token eq ')' or croak "unexpected token : $token";
328 $left = $left ? [@$left, [PAREN => [$right] ]]
329 : [PAREN => [$right] ];
332 elsif ($token =~ /^ (?: OR | AND ) $/xi ) {
334 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
336 # Merge chunks if logic matches
337 if (ref $right and $op eq $right->[0]) {
338 $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
341 $left = [$op => [$left, $right]];
344 # expression terminator keywords (as they start a new expression)
345 elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
347 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
348 $left = $left ? [@$left, [$op => [$right] ]]
349 : [ [$op => [$right] ] ];
353 $left = $left ? [@$left, [EXPR => $token] ]
354 : [ EXPR => $token ];
367 elsif (ref $tree->[0]) {
368 return join (" ", map { unparse ($_) } @$tree);
370 elsif ($tree->[0] eq 'EXPR') {
373 elsif ($tree->[0] eq 'PAREN') {
374 return sprintf '( %s )', join (" ", map {unparse($_)} @{$tree->[1]});
376 elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND') {
377 return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]});
380 return sprintf '%s %s', $tree->[0], unparse ($tree->[1]);
392 SQL::Abstract::Test - Helper function for testing SQL::Abstract
398 use SQL::Abstract::Test import => [qw/
399 is_same_sql_bind is_same_sql is_same_bind
400 eq_sql_bind eq_sql eq_bind
403 my ($sql, @bind) = SQL::Abstract->new->select(%args);
405 is_same_sql_bind($given_sql, \@given_bind,
406 $expected_sql, \@expected_bind, $test_msg);
408 is_same_sql($given_sql, $expected_sql, $test_msg);
409 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
411 my $is_same = eq_sql_bind($given_sql, \@given_bind,
412 $expected_sql, \@expected_bind);
414 my $sql_same = eq_sql($given_sql, $expected_sql);
415 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
419 This module is only intended for authors of tests on
420 L<SQL::Abstract|SQL::Abstract> and related modules;
421 it exports functions for comparing two SQL statements
422 and their bound values.
424 The SQL comparison is performed on I<abstract syntax>,
425 ignoring differences in spaces or in levels of parentheses.
426 Therefore the tests will pass as long as the semantics
427 is preserved, even if the surface syntax has changed.
429 B<Disclaimer> : this is only a half-cooked semantic equivalence;
430 parsing is simple-minded, and comparison of SQL abstract syntax trees
431 ignores commutativity or associativity of AND/OR operators, Morgan
436 =head2 is_same_sql_bind
438 is_same_sql_bind($given_sql, \@given_bind,
439 $expected_sql, \@expected_bind, $test_msg);
441 Compares given and expected pairs of C<($sql, \@bind)>, and calls
442 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
443 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
444 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
445 L</is_same_bind>) that needs to be imported.
449 is_same_sql($given_sql, $expected_sql, $test_msg);
451 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
452 the result, with C<$test_msg> as message. If the test fails, a detailed
453 diagnostic is printed. For clients which use L<Test::More>, this is the one of
454 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
455 that needs to be imported.
459 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
461 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
462 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
463 is printed. For clients which use L<Test::More>, this is the one of the three
464 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
469 my $is_same = eq_sql_bind($given_sql, \@given_bind,
470 $expected_sql, \@expected_bind);
472 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
473 L</is_same_sql_bind>, but it just returns a boolean value and does not print
474 diagnostics or talk to L<Test::Builder>.
478 my $is_same = eq_sql($given_sql, $expected_sql);
480 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
481 but it just returns a boolean value and does not print diagnostics or talk to
482 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
483 will contain the SQL portion where a difference was encountered; this is useful
484 for printing diagnostics.
488 my $is_same = eq_sql(\@given_bind, \@expected_bind);
490 Compares two lists of bind values, taking into account the fact that some of
491 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
492 L</is_same_bind>, but it just returns a boolean value and does not print
493 diagnostics or talk to L<Test::Builder>.
495 =head1 GLOBAL VARIABLES
497 =head2 $case_sensitive
499 If true, SQL comparisons will be case-sensitive. Default is false;
503 When L</eq_sql> returns false, the global variable
504 C<$sql_differ> contains the SQL portion
505 where a difference was encountered.
510 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
514 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
516 Norbert Buchmuller <norbi@nix.hu>
518 =head1 COPYRIGHT AND LICENSE
520 Copyright 2008 by Laurent Dami.
522 This library is free software; you can redistribute it and/or modify
523 it under the same terms as Perl itself.