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+ )?
55 # These are binary operator keywords always a single LHS and RHS
56 # * AND/OR are handled separately as they are N-ary
57 # * so is NOT as being unary
58 # * BETWEEN without paranthesis around the ANDed arguments (which
59 # makes it a non-binary op) is detected and accomodated in
61 my $stuff_around_mathops = qr/[\w\s\`\'\)]/;
62 my @binary_op_keywords = (
64 { " (?<= $stuff_around_mathops) " . quotemeta $_ . "(?= $stuff_around_mathops )" }
68 { '\b (?: NOT \s+)?' . $_ . '\b' }
73 my $tokenizer_re_str = join("\n\t|\n",
74 ( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR', 'NOT'),
78 my $tokenizer_re = qr/ \s* ( \( | \) | \? | $tokenizer_re_str ) \s* /xi;
80 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
81 my @unrollable_ops = (
89 sub is_same_sql_bind {
90 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
93 my $same_sql = eq_sql($sql1, $sql2);
94 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
96 # call Test::Builder::ok
97 my $ret = $tb->ok($same_sql && $same_bind, $msg);
101 _sql_differ_diag($sql1, $sql2);
104 _bind_differ_diag($bind_ref1, $bind_ref2);
107 # pass ok() result further
112 my ($sql1, $sql2, $msg) = @_;
115 my $same_sql = eq_sql($sql1, $sql2);
117 # call Test::Builder::ok
118 my $ret = $tb->ok($same_sql, $msg);
122 _sql_differ_diag($sql1, $sql2);
125 # pass ok() result further
130 my ($bind_ref1, $bind_ref2, $msg) = @_;
133 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
135 # call Test::Builder::ok
136 my $ret = $tb->ok($same_bind, $msg);
140 _bind_differ_diag($bind_ref1, $bind_ref2);
143 # pass ok() result further
147 sub _sql_differ_diag {
148 my ($sql1, $sql2) = @_;
150 $tb->diag("SQL expressions differ\n"
153 ."differing in :\n$sql_differ\n"
157 sub _bind_differ_diag {
158 my ($bind_ref1, $bind_ref2) = @_;
160 $tb->diag("BIND values differ\n"
161 ." got: " . Dumper($bind_ref1)
162 ."expected: " . Dumper($bind_ref2)
167 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
169 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
174 my ($bind_ref1, $bind_ref2) = @_;
176 return eq_deeply($bind_ref1, $bind_ref2);
180 my ($sql1, $sql2) = @_;
183 my $tree1 = parse($sql1);
184 my $tree2 = parse($sql2);
186 return 1 if _eq_sql($tree1, $tree2);
190 my ($left, $right) = @_;
192 # one is defined the other not
193 if ( (defined $left) xor (defined $right) ) {
196 # one is undefined, then so is the other
197 elsif (not defined $left) {
200 # one is a list, the other is an op with a list
201 elsif (ref $left->[0] xor ref $right->[0]) {
202 $sql_differ = sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) );
205 # one is a list, so is the other
206 elsif (ref $left->[0]) {
207 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
208 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
212 # both are an op-list combo
215 # unroll parenthesis if possible/allowed
216 _parenthesis_unroll ($_) for ($left, $right);
218 # if operators are different
219 if ($left->[0] ne $right->[0]) {
220 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
225 # elsif operators are identical, compare operands
227 if ($left->[0] eq 'EXPR' ) { # unary operator
228 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
229 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
230 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
231 $sql_differ = "[$l] != [$r]\n" if not $eq;
235 my $eq = _eq_sql($left->[1], $right->[1]);
236 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq;
246 # tokenize string, and remove all optional whitespace
248 foreach my $token (split $tokenizer_re, $s) {
250 $token =~ s/\s+([^\w\s])/$1/g;
251 $token =~ s/([^\w\s])\s+/$1/g;
252 push @$tokens, $token if length $token;
255 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
260 my ($tokens, $state) = @_;
263 while (1) { # left-associative parsing
265 my $lookahead = $tokens->[0];
266 if ( not defined($lookahead)
268 ($state == PARSE_IN_PARENS && $lookahead eq ')')
270 ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords ) )
272 ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords, @binary_op_keywords, 'AND', 'OR', 'NOT' ) )
277 my $token = shift @$tokens;
279 # nested expression in ()
281 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
282 $token = shift @$tokens or croak "missing closing ')' around block " . unparse ($right);
283 $token eq ')' or croak "unexpected token '$token' terminating block " . unparse ($right);
284 $left = $left ? [@$left, [PAREN => [$right] ]]
285 : [PAREN => [$right] ];
288 elsif ($token =~ /^ (?: OR | AND ) $/xi ) {
290 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
292 # Merge chunks if logic matches
293 if (ref $right and $op eq $right->[0]) {
294 $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
297 $left = [$op => [$left, $right]];
300 # binary operator keywords
301 elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
303 my $right = _recurse_parse($tokens, PARSE_RHS);
305 # A between with a simple EXPR for a 1st RHS argument needs a
306 # rerun of the search to (hopefully) find the proper AND construct
307 if ($op eq 'BETWEEN' and $right->[0] eq 'EXPR') {
308 unshift @$tokens, $right->[1][0];
309 $right = _recurse_parse($tokens, PARSE_IN_EXPR);
312 $left = [$op => [$left, $right] ];
314 # expression terminator keywords (as they start a new expression)
315 elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
317 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
318 $left = $left ? [@$left, [$op => [$right] ]]
319 : [[ $op => [$right] ]];
321 # NOT (last as to allow all other NOT X pieces first)
322 elsif ( $token =~ /^ not $/ix ) {
324 my $right = _recurse_parse ($tokens, PARSE_RHS);
325 $left = $left ? [ @$left, [$op => [$right] ]]
326 : [[ $op => [$right] ]];
331 $left = $left ? [@$left, [EXPR => [$token] ] ]
332 : [ EXPR => [$token] ];
337 sub _parenthesis_unroll {
340 return if $parenthesis_significant;
341 return unless (ref $ast and ref $ast->[1]);
348 for my $child (@{$ast->[1]}) {
349 if (not ref $child or not $child->[0] eq 'PAREN') {
350 push @children, $child;
354 # unroll nested parenthesis
355 while ($child->[1][0][0] eq 'PAREN') {
356 $child = $child->[1][0];
360 # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
362 ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
364 $child->[1][0][0] eq $ast->[0]
366 push @children, @{$child->[1][0][1]};
370 # if the parent operator explcitly allows it nuke the parenthesis
371 elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
372 push @children, $child->[1][0];
376 # only one EXPR element in the parenthesis
378 @{$child->[1]} == 1 && $child->[1][0][0] eq 'EXPR'
380 push @children, $child->[1][0];
384 # only one element in the parenthesis which is a binary op with two EXPR sub-children
388 grep { $child->[1][0][0] =~ /^ $_ $/xi } (@binary_op_keywords)
390 $child->[1][0][1][0][0] eq 'EXPR'
392 $child->[1][0][1][1][0] eq 'EXPR'
394 push @children, $child->[1][0];
398 # otherwise no more mucking for this pass
400 push @children, $child;
404 $ast->[1] = \@children;
416 elsif (ref $tree->[0]) {
417 return join (" ", map { unparse ($_) } @$tree);
419 elsif ($tree->[0] eq 'EXPR') {
420 return $tree->[1][0];
422 elsif ($tree->[0] eq 'PAREN') {
423 return sprintf '(%s)', join (" ", map {unparse($_)} @{$tree->[1]});
425 elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @binary_op_keywords ) ) {
426 return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]});
429 return sprintf '%s %s', $tree->[0], unparse ($tree->[1]);
441 SQL::Abstract::Test - Helper function for testing SQL::Abstract
447 use SQL::Abstract::Test import => [qw/
448 is_same_sql_bind is_same_sql is_same_bind
449 eq_sql_bind eq_sql eq_bind
452 my ($sql, @bind) = SQL::Abstract->new->select(%args);
454 is_same_sql_bind($given_sql, \@given_bind,
455 $expected_sql, \@expected_bind, $test_msg);
457 is_same_sql($given_sql, $expected_sql, $test_msg);
458 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
460 my $is_same = eq_sql_bind($given_sql, \@given_bind,
461 $expected_sql, \@expected_bind);
463 my $sql_same = eq_sql($given_sql, $expected_sql);
464 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
468 This module is only intended for authors of tests on
469 L<SQL::Abstract|SQL::Abstract> and related modules;
470 it exports functions for comparing two SQL statements
471 and their bound values.
473 The SQL comparison is performed on I<abstract syntax>,
474 ignoring differences in spaces or in levels of parentheses.
475 Therefore the tests will pass as long as the semantics
476 is preserved, even if the surface syntax has changed.
478 B<Disclaimer> : the semantic equivalence handling is pretty limited.
479 A lot of effort goes into distinguishing significant from
480 non-significant parenthesis, including AND/OR operator associativity.
481 Currently this module does not support commutativity and more
482 intelligent transformations like Morgan laws, etc.
484 For a good overview of what this test framework is capable of refer
489 =head2 is_same_sql_bind
491 is_same_sql_bind($given_sql, \@given_bind,
492 $expected_sql, \@expected_bind, $test_msg);
494 Compares given and expected pairs of C<($sql, \@bind)>, and calls
495 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
496 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
497 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
498 L</is_same_bind>) that needs to be imported.
502 is_same_sql($given_sql, $expected_sql, $test_msg);
504 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
505 the result, with C<$test_msg> as message. If the test fails, a detailed
506 diagnostic is printed. For clients which use L<Test::More>, this is the one of
507 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
508 that needs to be imported.
512 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
514 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
515 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
516 is printed. For clients which use L<Test::More>, this is the one of the three
517 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
522 my $is_same = eq_sql_bind($given_sql, \@given_bind,
523 $expected_sql, \@expected_bind);
525 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
526 L</is_same_sql_bind>, but it just returns a boolean value and does not print
527 diagnostics or talk to L<Test::Builder>.
531 my $is_same = eq_sql($given_sql, $expected_sql);
533 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
534 but it just returns a boolean value and does not print diagnostics or talk to
535 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
536 will contain the SQL portion where a difference was encountered; this is useful
537 for printing diagnostics.
541 my $is_same = eq_sql(\@given_bind, \@expected_bind);
543 Compares two lists of bind values, taking into account the fact that some of
544 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
545 L</is_same_bind>, but it just returns a boolean value and does not print
546 diagnostics or talk to L<Test::Builder>.
548 =head1 GLOBAL VARIABLES
550 =head2 $case_sensitive
552 If true, SQL comparisons will be case-sensitive. Default is false;
554 =head2 $parenthesis_significant
556 If true, SQL comparison will preserve and report difference in nested
557 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
561 When L</eq_sql> returns false, the global variable
562 C<$sql_differ> contains the SQL portion
563 where a difference was encountered.
568 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
572 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
574 Norbert Buchmuller <norbi@nix.hu>
576 Peter Rabbitson <ribasushi@cpan.org>
578 =head1 COPYRIGHT AND LICENSE
580 Copyright 2008 by Laurent Dami.
582 This library is free software; you can redistribute it and/or modify
583 it under the same terms as Perl itself.