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 $parenthesis_significant = 0;
17 our $sql_differ; # keeps track of differing portion between SQLs
18 our $tb = __PACKAGE__->builder;
20 # Parser states for _recurse_parse()
21 use constant PARSE_TOP_LEVEL => 0;
22 use constant PARSE_IN_EXPR => 1;
23 use constant PARSE_IN_PARENS => 2;
24 use constant PARSE_RHS => 3;
26 # These SQL keywords always signal end of the current expression (except inside
27 # of a parenthesized subexpression).
28 # Format: A list of strings that will be compiled to extended syntax (ie.
29 # /.../x) regexes, without capturing parentheses. They will be automatically
30 # anchored to word boundaries to match the whole token).
31 my @expression_terminator_sql_keywords = (
36 (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
37 (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
54 # These are binary operator keywords always a single LHS and RHS
55 # * AND/OR are handled separately as they are N-ary
56 # * so is NOT as being unary
57 # * BETWEEN without paranthesis around the ANDed arguments (which
58 # makes it a non-binary op) is detected and accomodated in
60 my @binary_op_keywords = (
61 (map { "\Q$_\E" } (qw/< > != = <= >=/)),
63 '(?: NOT \s+)? BETWEEN',
66 my $tokenizer_re_str = join("\n\t|\n",
67 ( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR', 'NOT'),
68 ( map { q! (?<= [\w\s\`\'\)] ) ! . $_ . q! (?= [\w\s\`\'\(] ) ! } @binary_op_keywords ),
71 my $tokenizer_re = qr/ \s* ( \( | \) | \? | $tokenizer_re_str ) \s* /xi;
73 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
74 my @unrollable_ops = (
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 # unroll parenthesis if possible/allowed
209 _parenthesis_unroll ($_) for ($left, $right);
211 # if operators are different
212 if ($left->[0] ne $right->[0]) {
213 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
218 # elsif operators are identical, compare operands
220 if ($left->[0] eq 'EXPR' ) { # unary operator
221 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
222 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
223 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
224 $sql_differ = "[$l] != [$r]\n" if not $eq;
228 my $eq = _eq_sql($left->[1], $right->[1]);
229 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq;
239 # tokenize string, and remove all optional whitespace
241 foreach my $token (split $tokenizer_re, $s) {
243 $token =~ s/\s+([^\w\s])/$1/g;
244 $token =~ s/([^\w\s])\s+/$1/g;
245 push @$tokens, $token if length $token;
248 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
253 my ($tokens, $state) = @_;
256 while (1) { # left-associative parsing
258 my $lookahead = $tokens->[0];
259 if ( not defined($lookahead)
261 ($state == PARSE_IN_PARENS && $lookahead eq ')')
263 ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords ) )
265 ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords, @binary_op_keywords, 'AND', 'OR', 'NOT' ) )
270 my $token = shift @$tokens;
272 # nested expression in ()
274 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
275 $token = shift @$tokens or croak "missing closing ')' around block " . unparse ($right);
276 $token eq ')' or croak "unexpected token '$token' terminating block " . unparse ($right);
277 $left = $left ? [@$left, [PAREN => [$right] ]]
278 : [PAREN => [$right] ];
281 elsif ($token =~ /^ (?: OR | AND ) $/xi ) {
283 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
285 # Merge chunks if logic matches
286 if (ref $right and $op eq $right->[0]) {
287 $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
290 $left = [$op => [$left, $right]];
293 # binary operator keywords
294 elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
296 my $right = _recurse_parse($tokens, PARSE_RHS);
298 # A between with a simple EXPR for a 1st RHS argument needs a
299 # rerun of the search to (hopefully) find the proper AND construct
300 if ($op eq 'BETWEEN' and $right->[0] eq 'EXPR') {
301 unshift @$tokens, $right->[1][0];
302 $right = _recurse_parse($tokens, PARSE_IN_EXPR);
305 $left = [$op => [$left, $right] ];
307 # expression terminator keywords (as they start a new expression)
308 elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
310 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
311 $left = $left ? [@$left, [$op => [$right] ]]
312 : [[ $op => [$right] ]];
314 # NOT (last as to allow all other NOT X pieces first)
315 elsif ( $token =~ /^ not $/ix ) {
317 my $right = _recurse_parse ($tokens, PARSE_RHS);
318 $left = $left ? [ @$left, [$op => [$right] ]]
319 : [[ $op => [$right] ]];
324 $left = $left ? [@$left, [EXPR => [$token] ] ]
325 : [ EXPR => [$token] ];
330 sub _parenthesis_unroll {
333 return if $parenthesis_significant;
334 return unless (ref $ast and ref $ast->[1]);
341 for my $child (@{$ast->[1]}) {
342 if (not ref $child or not $child->[0] eq 'PAREN') {
343 push @children, $child;
347 # unroll nested parenthesis
348 while ($child->[1][0][0] eq 'PAREN') {
349 $child = $child->[1][0];
353 # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
355 ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
357 $child->[1][0][0] eq $ast->[0]
359 push @children, @{$child->[1][0][1]};
363 # if the parent operator explcitly allows it nuke the parenthesis
364 elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
365 push @children, $child->[1][0];
369 # only one EXPR element in the parenthesis
371 @{$child->[1]} == 1 && $child->[1][0][0] eq 'EXPR'
373 push @children, $child->[1][0];
377 # only one element in the parenthesis which is a binary op with two EXPR sub-children
381 grep { $child->[1][0][0] =~ /^ $_ $/xi } (@binary_op_keywords)
383 $child->[1][0][1][0][0] eq 'EXPR'
385 $child->[1][0][1][1][0] eq 'EXPR'
387 push @children, $child->[1][0];
391 # otherwise no more mucking for this pass
393 push @children, $child;
397 $ast->[1] = \@children;
409 elsif (ref $tree->[0]) {
410 return join (" ", map { unparse ($_) } @$tree);
412 elsif ($tree->[0] eq 'EXPR') {
413 return $tree->[1][0];
415 elsif ($tree->[0] eq 'PAREN') {
416 return sprintf '(%s)', join (" ", map {unparse($_)} @{$tree->[1]});
418 elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @binary_op_keywords ) ) {
419 return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]});
422 return sprintf '%s %s', $tree->[0], unparse ($tree->[1]);
434 SQL::Abstract::Test - Helper function for testing SQL::Abstract
440 use SQL::Abstract::Test import => [qw/
441 is_same_sql_bind is_same_sql is_same_bind
442 eq_sql_bind eq_sql eq_bind
445 my ($sql, @bind) = SQL::Abstract->new->select(%args);
447 is_same_sql_bind($given_sql, \@given_bind,
448 $expected_sql, \@expected_bind, $test_msg);
450 is_same_sql($given_sql, $expected_sql, $test_msg);
451 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
453 my $is_same = eq_sql_bind($given_sql, \@given_bind,
454 $expected_sql, \@expected_bind);
456 my $sql_same = eq_sql($given_sql, $expected_sql);
457 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
461 This module is only intended for authors of tests on
462 L<SQL::Abstract|SQL::Abstract> and related modules;
463 it exports functions for comparing two SQL statements
464 and their bound values.
466 The SQL comparison is performed on I<abstract syntax>,
467 ignoring differences in spaces or in levels of parentheses.
468 Therefore the tests will pass as long as the semantics
469 is preserved, even if the surface syntax has changed.
471 B<Disclaimer> : the semantic equivalence handling is pretty limited.
472 A lot of effort goes into distinguishing significant from
473 non-significant parenthesis, including AND/OR operator associativity.
474 Currently this module does not support commutativity and more
475 intelligent transformations like Morgan laws, etc.
477 For a good overview of what this test framework is capable of refer
482 =head2 is_same_sql_bind
484 is_same_sql_bind($given_sql, \@given_bind,
485 $expected_sql, \@expected_bind, $test_msg);
487 Compares given and expected pairs of C<($sql, \@bind)>, and calls
488 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
489 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
490 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
491 L</is_same_bind>) that needs to be imported.
495 is_same_sql($given_sql, $expected_sql, $test_msg);
497 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
498 the result, with C<$test_msg> as message. If the test fails, a detailed
499 diagnostic is printed. For clients which use L<Test::More>, this is the one of
500 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
501 that needs to be imported.
505 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
507 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
508 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
509 is printed. For clients which use L<Test::More>, this is the one of the three
510 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
515 my $is_same = eq_sql_bind($given_sql, \@given_bind,
516 $expected_sql, \@expected_bind);
518 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
519 L</is_same_sql_bind>, but it just returns a boolean value and does not print
520 diagnostics or talk to L<Test::Builder>.
524 my $is_same = eq_sql($given_sql, $expected_sql);
526 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
527 but it just returns a boolean value and does not print diagnostics or talk to
528 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
529 will contain the SQL portion where a difference was encountered; this is useful
530 for printing diagnostics.
534 my $is_same = eq_sql(\@given_bind, \@expected_bind);
536 Compares two lists of bind values, taking into account the fact that some of
537 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
538 L</is_same_bind>, but it just returns a boolean value and does not print
539 diagnostics or talk to L<Test::Builder>.
541 =head1 GLOBAL VARIABLES
543 =head2 $case_sensitive
545 If true, SQL comparisons will be case-sensitive. Default is false;
547 =head2 $parenthesis_significant
549 If true, SQL comparison will preserve and report difference in nested
550 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
554 When L</eq_sql> returns false, the global variable
555 C<$sql_differ> contains the SQL portion
556 where a difference was encountered.
561 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
565 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
567 Norbert Buchmuller <norbi@nix.hu>
569 Peter Rabbitson <ribasushi@cpan.org>
571 =head1 COPYRIGHT AND LICENSE
573 Copyright 2008 by Laurent Dami.
575 This library is free software; you can redistribute it and/or modify
576 it under the same terms as Perl itself.