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_TOP_LEVEL => 0;
21 use constant PARSE_IN_EXPR => 1;
22 use constant PARSE_IN_PARENS => 2;
23 use constant PARSE_RHS => 3;
25 # These SQL keywords always signal end of the current expression (except inside
26 # of a parenthesized subexpression).
27 # Format: A list of strings that will be compiled to extended syntax (ie.
28 # /.../x) regexes, without capturing parentheses. They will be automatically
29 # anchored to word boundaries to match the whole token).
30 my @expression_terminator_sql_keywords = (
35 (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
36 (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
53 # These are binary operator keywords always a single LHS and RHS
54 # * AND/OR are handled separately as they are N-ary
55 # * BETWEEN without paranthesis around the ANDed arguments (which
56 # makes it a non-binary op) is detected and accomodated in
58 my @binary_op_keywords = (
59 (map { "\Q$_\E" } (qw/< > != = <= >=/)),
61 '(?: NOT \s+)? BETWEEN',
64 my $tokenizer_re_str = join("\n\t|\n",
65 ( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR' ),
66 ( map { q! (?<= [\w\s\`\'\)] ) ! . $_ . q! (?= [\w\s\`\'\(] ) ! } @binary_op_keywords ),
69 my $tokenizer_re = qr/ \s* ( \( | \) | \? | $tokenizer_re_str ) \s* /xi;
71 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
72 my @unrollable_ops = (
80 sub is_same_sql_bind {
81 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
84 my $same_sql = eq_sql($sql1, $sql2);
85 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
87 # call Test::Builder::ok
88 my $ret = $tb->ok($same_sql && $same_bind, $msg);
92 _sql_differ_diag($sql1, $sql2);
95 _bind_differ_diag($bind_ref1, $bind_ref2);
98 # pass ok() result further
103 my ($sql1, $sql2, $msg) = @_;
106 my $same_sql = eq_sql($sql1, $sql2);
108 # call Test::Builder::ok
109 my $ret = $tb->ok($same_sql, $msg);
113 _sql_differ_diag($sql1, $sql2);
116 # pass ok() result further
121 my ($bind_ref1, $bind_ref2, $msg) = @_;
124 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
126 # call Test::Builder::ok
127 my $ret = $tb->ok($same_bind, $msg);
131 _bind_differ_diag($bind_ref1, $bind_ref2);
134 # pass ok() result further
138 sub _sql_differ_diag {
139 my ($sql1, $sql2) = @_;
141 $tb->diag("SQL expressions differ\n"
144 ."differing in :\n$sql_differ\n"
148 sub _bind_differ_diag {
149 my ($bind_ref1, $bind_ref2) = @_;
151 $tb->diag("BIND values differ\n"
152 ." got: " . Dumper($bind_ref1)
153 ."expected: " . Dumper($bind_ref2)
158 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
160 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
165 my ($bind_ref1, $bind_ref2) = @_;
167 return eq_deeply($bind_ref1, $bind_ref2);
171 my ($sql1, $sql2) = @_;
174 my $tree1 = parse($sql1);
175 my $tree2 = parse($sql2);
177 return 1 if _eq_sql($tree1, $tree2);
181 my ($left, $right) = @_;
183 # one is defined the other not
184 if ( (defined $left) xor (defined $right) ) {
187 # one is undefined, then so is the other
188 elsif (not defined $left) {
191 # one is a list, the other is an op with a list
192 elsif (ref $left->[0] xor ref $right->[0]) {
193 $sql_differ = sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) );
196 # one is a list, so is the other
197 elsif (ref $left->[0]) {
198 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
199 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
203 # both are an op-list combo
206 for my $ast ($left, $right) {
208 next unless (ref $ast->[1]);
210 # unroll parenthesis in an elaborate loop
217 for my $child (@{$ast->[1]}) {
218 if (not ref $child or not $child->[0] eq 'PAREN') {
219 push @children, $child;
223 # unroll nested parenthesis
224 while ($child->[1][0][0] eq 'PAREN') {
225 $child = $child->[1][0];
229 # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
231 ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
233 $child->[1][0][0] eq $ast->[0]
235 push @children, @{$child->[1][0][1]};
239 # if the parent operator explcitly allows it nuke the parenthesis
240 elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
241 push @children, $child->[1][0];
245 # only one element in the parenthesis which is a binary op with two EXPR sub-children
249 grep { $child->[1][0][0] =~ /^ $_ $/xi } (@binary_op_keywords)
251 $child->[1][0][1][0][0] eq 'EXPR'
253 $child->[1][0][1][1][0] eq 'EXPR'
255 push @children, $child->[1][0];
259 # otherwise no more mucking for this pass
261 push @children, $child;
265 $ast->[1] = \@children;
269 # if operators are different
270 if ($left->[0] ne $right->[0]) {
271 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
276 # elsif operators are identical, compare operands
278 if ($left->[0] eq 'EXPR' ) { # unary operator
279 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
280 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
281 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
282 $sql_differ = "[$l] != [$r]\n" if not $eq;
286 my $eq = _eq_sql($left->[1], $right->[1]);
287 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq;
298 # tokenize string, and remove all optional whitespace
300 foreach my $token (split $tokenizer_re, $s) {
302 $token =~ s/\s+([^\w\s])/$1/g;
303 $token =~ s/([^\w\s])\s+/$1/g;
304 push @$tokens, $token if length $token;
307 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
312 my ($tokens, $state) = @_;
315 while (1) { # left-associative parsing
317 my $lookahead = $tokens->[0];
318 if ( not defined($lookahead)
320 ($state == PARSE_IN_PARENS && $lookahead eq ')')
322 ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords ) )
324 ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords, @binary_op_keywords, 'AND', 'OR' ) )
329 my $token = shift @$tokens;
331 # nested expression in ()
333 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
334 $token = shift @$tokens or croak "missing ')'";
335 $token eq ')' or croak "unexpected token : $token";
336 $left = $left ? [@$left, [PAREN => [$right] ]]
337 : [PAREN => [$right] ];
340 elsif ($token =~ /^ (?: OR | AND ) $/xi ) {
342 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
344 # Merge chunks if logic matches
345 if (ref $right and $op eq $right->[0]) {
346 $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
349 $left = [$op => [$left, $right]];
352 # binary operator keywords
353 elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
355 my $right = _recurse_parse($tokens, PARSE_RHS);
357 # A between with a simple EXPR for a 1st RHS argument needs a
358 # rerun of the search to (hopefully) find the proper AND construct
359 if ($op eq 'BETWEEN' and $right->[0] eq 'EXPR') {
360 unshift @$tokens, $right->[1][0];
361 $right = _recurse_parse($tokens, PARSE_IN_EXPR);
364 $left = [$op => [$left, $right] ];
366 # expression terminator keywords (as they start a new expression)
367 elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
369 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
370 $left = $left ? [@$left, [$op => [$right] ]]
371 : [[ $op => [$right] ]];
375 $left = $left ? [@$left, [EXPR => [$token] ] ]
376 : [ EXPR => [$token] ];
389 elsif (ref $tree->[0]) {
390 return join (" ", map { unparse ($_) } @$tree);
392 elsif ($tree->[0] eq 'EXPR') {
393 return $tree->[1][0];
395 elsif ($tree->[0] eq 'PAREN') {
396 return sprintf '(%s)', join (" ", map {unparse($_)} @{$tree->[1]});
398 elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @binary_op_keywords ) ) {
399 return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]});
402 return sprintf '%s %s', $tree->[0], unparse ($tree->[1]);
414 SQL::Abstract::Test - Helper function for testing SQL::Abstract
420 use SQL::Abstract::Test import => [qw/
421 is_same_sql_bind is_same_sql is_same_bind
422 eq_sql_bind eq_sql eq_bind
425 my ($sql, @bind) = SQL::Abstract->new->select(%args);
427 is_same_sql_bind($given_sql, \@given_bind,
428 $expected_sql, \@expected_bind, $test_msg);
430 is_same_sql($given_sql, $expected_sql, $test_msg);
431 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
433 my $is_same = eq_sql_bind($given_sql, \@given_bind,
434 $expected_sql, \@expected_bind);
436 my $sql_same = eq_sql($given_sql, $expected_sql);
437 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
441 This module is only intended for authors of tests on
442 L<SQL::Abstract|SQL::Abstract> and related modules;
443 it exports functions for comparing two SQL statements
444 and their bound values.
446 The SQL comparison is performed on I<abstract syntax>,
447 ignoring differences in spaces or in levels of parentheses.
448 Therefore the tests will pass as long as the semantics
449 is preserved, even if the surface syntax has changed.
451 B<Disclaimer> : this is only a half-cooked semantic equivalence;
452 parsing is simple-minded, and comparison of SQL abstract syntax trees
453 ignores commutativity or associativity of AND/OR operators, Morgan
458 =head2 is_same_sql_bind
460 is_same_sql_bind($given_sql, \@given_bind,
461 $expected_sql, \@expected_bind, $test_msg);
463 Compares given and expected pairs of C<($sql, \@bind)>, and calls
464 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
465 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
466 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
467 L</is_same_bind>) that needs to be imported.
471 is_same_sql($given_sql, $expected_sql, $test_msg);
473 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
474 the result, with C<$test_msg> as message. If the test fails, a detailed
475 diagnostic is printed. For clients which use L<Test::More>, this is the one of
476 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
477 that needs to be imported.
481 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
483 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
484 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
485 is printed. For clients which use L<Test::More>, this is the one of the three
486 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
491 my $is_same = eq_sql_bind($given_sql, \@given_bind,
492 $expected_sql, \@expected_bind);
494 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
495 L</is_same_sql_bind>, but it just returns a boolean value and does not print
496 diagnostics or talk to L<Test::Builder>.
500 my $is_same = eq_sql($given_sql, $expected_sql);
502 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
503 but it just returns a boolean value and does not print diagnostics or talk to
504 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
505 will contain the SQL portion where a difference was encountered; this is useful
506 for printing diagnostics.
510 my $is_same = eq_sql(\@given_bind, \@expected_bind);
512 Compares two lists of bind values, taking into account the fact that some of
513 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
514 L</is_same_bind>, but it just returns a boolean value and does not print
515 diagnostics or talk to L<Test::Builder>.
517 =head1 GLOBAL VARIABLES
519 =head2 $case_sensitive
521 If true, SQL comparisons will be case-sensitive. Default is false;
525 When L</eq_sql> returns false, the global variable
526 C<$sql_differ> contains the SQL portion
527 where a difference was encountered.
532 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
536 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
538 Norbert Buchmuller <norbi@nix.hu>
540 =head1 COPYRIGHT AND LICENSE
542 Copyright 2008 by Laurent Dami.
544 This library is free software; you can redistribute it and/or modify
545 it under the same terms as Perl itself.