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 # * BETWEEN without paranthesis around the ANDed arguments (which
57 # makes it a non-binary op) is detected and accomodated in
59 my @binary_op_keywords = (
60 (map { "\Q$_\E" } (qw/< > != = <= >=/)),
62 '(?: NOT \s+)? BETWEEN',
65 my $tokenizer_re_str = join("\n\t|\n",
66 ( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR' ),
67 ( map { q! (?<= [\w\s\`\'\)] ) ! . $_ . q! (?= [\w\s\`\'\(] ) ! } @binary_op_keywords ),
70 my $tokenizer_re = qr/ \s* ( \( | \) | \? | $tokenizer_re_str ) \s* /xi;
72 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
73 my @unrollable_ops = (
81 sub is_same_sql_bind {
82 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
85 my $same_sql = eq_sql($sql1, $sql2);
86 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
88 # call Test::Builder::ok
89 my $ret = $tb->ok($same_sql && $same_bind, $msg);
93 _sql_differ_diag($sql1, $sql2);
96 _bind_differ_diag($bind_ref1, $bind_ref2);
99 # pass ok() result further
104 my ($sql1, $sql2, $msg) = @_;
107 my $same_sql = eq_sql($sql1, $sql2);
109 # call Test::Builder::ok
110 my $ret = $tb->ok($same_sql, $msg);
114 _sql_differ_diag($sql1, $sql2);
117 # pass ok() result further
122 my ($bind_ref1, $bind_ref2, $msg) = @_;
125 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
127 # call Test::Builder::ok
128 my $ret = $tb->ok($same_bind, $msg);
132 _bind_differ_diag($bind_ref1, $bind_ref2);
135 # pass ok() result further
139 sub _sql_differ_diag {
140 my ($sql1, $sql2) = @_;
142 $tb->diag("SQL expressions differ\n"
145 ."differing in :\n$sql_differ\n"
149 sub _bind_differ_diag {
150 my ($bind_ref1, $bind_ref2) = @_;
152 $tb->diag("BIND values differ\n"
153 ." got: " . Dumper($bind_ref1)
154 ."expected: " . Dumper($bind_ref2)
159 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
161 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
166 my ($bind_ref1, $bind_ref2) = @_;
168 return eq_deeply($bind_ref1, $bind_ref2);
172 my ($sql1, $sql2) = @_;
175 my $tree1 = parse($sql1);
176 my $tree2 = parse($sql2);
178 return 1 if _eq_sql($tree1, $tree2);
182 my ($left, $right) = @_;
184 # one is defined the other not
185 if ( (defined $left) xor (defined $right) ) {
188 # one is undefined, then so is the other
189 elsif (not defined $left) {
192 # one is a list, the other is an op with a list
193 elsif (ref $left->[0] xor ref $right->[0]) {
194 $sql_differ = sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) );
197 # one is a list, so is the other
198 elsif (ref $left->[0]) {
199 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
200 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
204 # both are an op-list combo
207 # unroll parenthesis if possible/allowed
208 _parenthesis_unroll ($_) for ($left, $right);
210 # if operators are different
211 if ($left->[0] ne $right->[0]) {
212 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
217 # elsif operators are identical, compare operands
219 if ($left->[0] eq 'EXPR' ) { # unary operator
220 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
221 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
222 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
223 $sql_differ = "[$l] != [$r]\n" if not $eq;
227 my $eq = _eq_sql($left->[1], $right->[1]);
228 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq;
238 # tokenize string, and remove all optional whitespace
240 foreach my $token (split $tokenizer_re, $s) {
242 $token =~ s/\s+([^\w\s])/$1/g;
243 $token =~ s/([^\w\s])\s+/$1/g;
244 push @$tokens, $token if length $token;
247 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
252 my ($tokens, $state) = @_;
255 while (1) { # left-associative parsing
257 my $lookahead = $tokens->[0];
258 if ( not defined($lookahead)
260 ($state == PARSE_IN_PARENS && $lookahead eq ')')
262 ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords ) )
264 ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords, @binary_op_keywords, 'AND', 'OR' ) )
269 my $token = shift @$tokens;
271 # nested expression in ()
273 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
274 $token = shift @$tokens or croak "missing closing ')' around block " . unparse ($right);
275 $token eq ')' or croak "unexpected token '$token' terminating block " . unparse ($right);
276 $left = $left ? [@$left, [PAREN => [$right] ]]
277 : [PAREN => [$right] ];
280 elsif ($token =~ /^ (?: OR | AND ) $/xi ) {
282 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
284 # Merge chunks if logic matches
285 if (ref $right and $op eq $right->[0]) {
286 $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
289 $left = [$op => [$left, $right]];
292 # binary operator keywords
293 elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
295 my $right = _recurse_parse($tokens, PARSE_RHS);
297 # A between with a simple EXPR for a 1st RHS argument needs a
298 # rerun of the search to (hopefully) find the proper AND construct
299 if ($op eq 'BETWEEN' and $right->[0] eq 'EXPR') {
300 unshift @$tokens, $right->[1][0];
301 $right = _recurse_parse($tokens, PARSE_IN_EXPR);
304 $left = [$op => [$left, $right] ];
306 # expression terminator keywords (as they start a new expression)
307 elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
309 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
310 $left = $left ? [@$left, [$op => [$right] ]]
311 : [[ $op => [$right] ]];
315 $left = $left ? [@$left, [EXPR => [$token] ] ]
316 : [ EXPR => [$token] ];
321 sub _parenthesis_unroll {
324 return if $parenthesis_significant;
325 return unless (ref $ast and ref $ast->[1]);
332 for my $child (@{$ast->[1]}) {
333 if (not ref $child or not $child->[0] eq 'PAREN') {
334 push @children, $child;
338 # unroll nested parenthesis
339 while ($child->[1][0][0] eq 'PAREN') {
340 $child = $child->[1][0];
344 # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
346 ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
348 $child->[1][0][0] eq $ast->[0]
350 push @children, @{$child->[1][0][1]};
354 # if the parent operator explcitly allows it nuke the parenthesis
355 elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
356 push @children, $child->[1][0];
360 # only one element in the parenthesis which is a binary op with two EXPR sub-children
364 grep { $child->[1][0][0] =~ /^ $_ $/xi } (@binary_op_keywords)
366 $child->[1][0][1][0][0] eq 'EXPR'
368 $child->[1][0][1][1][0] eq 'EXPR'
370 push @children, $child->[1][0];
374 # otherwise no more mucking for this pass
376 push @children, $child;
380 $ast->[1] = \@children;
392 elsif (ref $tree->[0]) {
393 return join (" ", map { unparse ($_) } @$tree);
395 elsif ($tree->[0] eq 'EXPR') {
396 return $tree->[1][0];
398 elsif ($tree->[0] eq 'PAREN') {
399 return sprintf '(%s)', join (" ", map {unparse($_)} @{$tree->[1]});
401 elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @binary_op_keywords ) ) {
402 return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]});
405 return sprintf '%s %s', $tree->[0], unparse ($tree->[1]);
417 SQL::Abstract::Test - Helper function for testing SQL::Abstract
423 use SQL::Abstract::Test import => [qw/
424 is_same_sql_bind is_same_sql is_same_bind
425 eq_sql_bind eq_sql eq_bind
428 my ($sql, @bind) = SQL::Abstract->new->select(%args);
430 is_same_sql_bind($given_sql, \@given_bind,
431 $expected_sql, \@expected_bind, $test_msg);
433 is_same_sql($given_sql, $expected_sql, $test_msg);
434 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
436 my $is_same = eq_sql_bind($given_sql, \@given_bind,
437 $expected_sql, \@expected_bind);
439 my $sql_same = eq_sql($given_sql, $expected_sql);
440 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
444 This module is only intended for authors of tests on
445 L<SQL::Abstract|SQL::Abstract> and related modules;
446 it exports functions for comparing two SQL statements
447 and their bound values.
449 The SQL comparison is performed on I<abstract syntax>,
450 ignoring differences in spaces or in levels of parentheses.
451 Therefore the tests will pass as long as the semantics
452 is preserved, even if the surface syntax has changed.
454 B<Disclaimer> : the semantic equivalence handling is pretty limited.
455 A lot of effort goes into distinguishing significant from
456 non-significant parenthesis, including AND/OR operator associativity.
457 Currently this module does not support commutativity and more
458 intelligent transformations like Morgan laws, etc.
460 For a good overview of what this test framework is capable of refer
465 =head2 is_same_sql_bind
467 is_same_sql_bind($given_sql, \@given_bind,
468 $expected_sql, \@expected_bind, $test_msg);
470 Compares given and expected pairs of C<($sql, \@bind)>, and calls
471 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
472 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
473 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
474 L</is_same_bind>) that needs to be imported.
478 is_same_sql($given_sql, $expected_sql, $test_msg);
480 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
481 the result, with C<$test_msg> as message. If the test fails, a detailed
482 diagnostic is printed. For clients which use L<Test::More>, this is the one of
483 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
484 that needs to be imported.
488 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
490 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
491 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
492 is printed. For clients which use L<Test::More>, this is the one of the three
493 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
498 my $is_same = eq_sql_bind($given_sql, \@given_bind,
499 $expected_sql, \@expected_bind);
501 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
502 L</is_same_sql_bind>, but it just returns a boolean value and does not print
503 diagnostics or talk to L<Test::Builder>.
507 my $is_same = eq_sql($given_sql, $expected_sql);
509 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
510 but it just returns a boolean value and does not print diagnostics or talk to
511 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
512 will contain the SQL portion where a difference was encountered; this is useful
513 for printing diagnostics.
517 my $is_same = eq_sql(\@given_bind, \@expected_bind);
519 Compares two lists of bind values, taking into account the fact that some of
520 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
521 L</is_same_bind>, but it just returns a boolean value and does not print
522 diagnostics or talk to L<Test::Builder>.
524 =head1 GLOBAL VARIABLES
526 =head2 $case_sensitive
528 If true, SQL comparisons will be case-sensitive. Default is false;
530 =head2 $parenthesis_significant
532 If true, SQL comparison will preserve and report difference in nested
533 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
537 When L</eq_sql> returns false, the global variable
538 C<$sql_differ> contains the SQL portion
539 where a difference was encountered.
544 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
548 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
550 Norbert Buchmuller <norbi@nix.hu>
552 Peter Rabbitson <ribasushi@cpan.org>
554 =head1 COPYRIGHT AND LICENSE
556 Copyright 2008 by Laurent Dami.
558 This library is free software; you can redistribute it and/or modify
559 it under the same terms as Perl itself.