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/< > != = <= >=/)),
64 '(?: NOT \s+)? BETWEEN',
67 my $tokenizer_re_str = join("\n\t|\n",
68 ( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR', 'NOT'),
69 ( map { q! (?<= [\w\s\`\'\)] ) ! . $_ . q! (?= [\w\s\`\'\(] ) ! } @binary_op_keywords ),
72 my $tokenizer_re = qr/ \s* ( \( | \) | \? | $tokenizer_re_str ) \s* /xi;
74 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
75 my @unrollable_ops = (
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 # unroll parenthesis if possible/allowed
210 _parenthesis_unroll ($_) for ($left, $right);
212 # if operators are different
213 if ($left->[0] ne $right->[0]) {
214 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
219 # elsif operators are identical, compare operands
221 if ($left->[0] eq 'EXPR' ) { # unary operator
222 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
223 (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
224 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
225 $sql_differ = "[$l] != [$r]\n" if not $eq;
229 my $eq = _eq_sql($left->[1], $right->[1]);
230 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq;
240 # tokenize string, and remove all optional whitespace
242 foreach my $token (split $tokenizer_re, $s) {
244 $token =~ s/\s+([^\w\s])/$1/g;
245 $token =~ s/([^\w\s])\s+/$1/g;
246 push @$tokens, $token if length $token;
249 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
254 my ($tokens, $state) = @_;
257 while (1) { # left-associative parsing
259 my $lookahead = $tokens->[0];
260 if ( not defined($lookahead)
262 ($state == PARSE_IN_PARENS && $lookahead eq ')')
264 ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords ) )
266 ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords, @binary_op_keywords, 'AND', 'OR', 'NOT' ) )
271 my $token = shift @$tokens;
273 # nested expression in ()
275 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
276 $token = shift @$tokens or croak "missing closing ')' around block " . unparse ($right);
277 $token eq ')' or croak "unexpected token '$token' terminating block " . unparse ($right);
278 $left = $left ? [@$left, [PAREN => [$right] ]]
279 : [PAREN => [$right] ];
282 elsif ($token =~ /^ (?: OR | AND ) $/xi ) {
284 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
286 # Merge chunks if logic matches
287 if (ref $right and $op eq $right->[0]) {
288 $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
291 $left = [$op => [$left, $right]];
294 # binary operator keywords
295 elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
297 my $right = _recurse_parse($tokens, PARSE_RHS);
299 # A between with a simple EXPR for a 1st RHS argument needs a
300 # rerun of the search to (hopefully) find the proper AND construct
301 if ($op eq 'BETWEEN' and $right->[0] eq 'EXPR') {
302 unshift @$tokens, $right->[1][0];
303 $right = _recurse_parse($tokens, PARSE_IN_EXPR);
306 $left = [$op => [$left, $right] ];
308 # expression terminator keywords (as they start a new expression)
309 elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
311 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
312 $left = $left ? [@$left, [$op => [$right] ]]
313 : [[ $op => [$right] ]];
315 # NOT (last as to allow all other NOT X pieces first)
316 elsif ( $token =~ /^ not $/ix ) {
318 my $right = _recurse_parse ($tokens, PARSE_RHS);
319 $left = $left ? [ @$left, [$op => [$right] ]]
320 : [[ $op => [$right] ]];
325 $left = $left ? [@$left, [EXPR => [$token] ] ]
326 : [ EXPR => [$token] ];
331 sub _parenthesis_unroll {
334 return if $parenthesis_significant;
335 return unless (ref $ast and ref $ast->[1]);
342 for my $child (@{$ast->[1]}) {
343 if (not ref $child or not $child->[0] eq 'PAREN') {
344 push @children, $child;
348 # unroll nested parenthesis
349 while ($child->[1][0][0] eq 'PAREN') {
350 $child = $child->[1][0];
354 # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
356 ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
358 $child->[1][0][0] eq $ast->[0]
360 push @children, @{$child->[1][0][1]};
364 # if the parent operator explcitly allows it nuke the parenthesis
365 elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
366 push @children, $child->[1][0];
370 # only one EXPR element in the parenthesis
372 @{$child->[1]} == 1 && $child->[1][0][0] eq 'EXPR'
374 push @children, $child->[1][0];
378 # only one element in the parenthesis which is a binary op with two EXPR sub-children
382 grep { $child->[1][0][0] =~ /^ $_ $/xi } (@binary_op_keywords)
384 $child->[1][0][1][0][0] eq 'EXPR'
386 $child->[1][0][1][1][0] eq 'EXPR'
388 push @children, $child->[1][0];
392 # otherwise no more mucking for this pass
394 push @children, $child;
398 $ast->[1] = \@children;
410 elsif (ref $tree->[0]) {
411 return join (" ", map { unparse ($_) } @$tree);
413 elsif ($tree->[0] eq 'EXPR') {
414 return $tree->[1][0];
416 elsif ($tree->[0] eq 'PAREN') {
417 return sprintf '(%s)', join (" ", map {unparse($_)} @{$tree->[1]});
419 elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @binary_op_keywords ) ) {
420 return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]});
423 return sprintf '%s %s', $tree->[0], unparse ($tree->[1]);
435 SQL::Abstract::Test - Helper function for testing SQL::Abstract
441 use SQL::Abstract::Test import => [qw/
442 is_same_sql_bind is_same_sql is_same_bind
443 eq_sql_bind eq_sql eq_bind
446 my ($sql, @bind) = SQL::Abstract->new->select(%args);
448 is_same_sql_bind($given_sql, \@given_bind,
449 $expected_sql, \@expected_bind, $test_msg);
451 is_same_sql($given_sql, $expected_sql, $test_msg);
452 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
454 my $is_same = eq_sql_bind($given_sql, \@given_bind,
455 $expected_sql, \@expected_bind);
457 my $sql_same = eq_sql($given_sql, $expected_sql);
458 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
462 This module is only intended for authors of tests on
463 L<SQL::Abstract|SQL::Abstract> and related modules;
464 it exports functions for comparing two SQL statements
465 and their bound values.
467 The SQL comparison is performed on I<abstract syntax>,
468 ignoring differences in spaces or in levels of parentheses.
469 Therefore the tests will pass as long as the semantics
470 is preserved, even if the surface syntax has changed.
472 B<Disclaimer> : the semantic equivalence handling is pretty limited.
473 A lot of effort goes into distinguishing significant from
474 non-significant parenthesis, including AND/OR operator associativity.
475 Currently this module does not support commutativity and more
476 intelligent transformations like Morgan laws, etc.
478 For a good overview of what this test framework is capable of refer
483 =head2 is_same_sql_bind
485 is_same_sql_bind($given_sql, \@given_bind,
486 $expected_sql, \@expected_bind, $test_msg);
488 Compares given and expected pairs of C<($sql, \@bind)>, and calls
489 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
490 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
491 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
492 L</is_same_bind>) that needs to be imported.
496 is_same_sql($given_sql, $expected_sql, $test_msg);
498 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
499 the result, with C<$test_msg> as message. If the test fails, a detailed
500 diagnostic is printed. For clients which use L<Test::More>, this is the one of
501 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
502 that needs to be imported.
506 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
508 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
509 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
510 is printed. For clients which use L<Test::More>, this is the one of the three
511 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
516 my $is_same = eq_sql_bind($given_sql, \@given_bind,
517 $expected_sql, \@expected_bind);
519 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
520 L</is_same_sql_bind>, but it just returns a boolean value and does not print
521 diagnostics or talk to L<Test::Builder>.
525 my $is_same = eq_sql($given_sql, $expected_sql);
527 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
528 but it just returns a boolean value and does not print diagnostics or talk to
529 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
530 will contain the SQL portion where a difference was encountered; this is useful
531 for printing diagnostics.
535 my $is_same = eq_sql(\@given_bind, \@expected_bind);
537 Compares two lists of bind values, taking into account the fact that some of
538 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
539 L</is_same_bind>, but it just returns a boolean value and does not print
540 diagnostics or talk to L<Test::Builder>.
542 =head1 GLOBAL VARIABLES
544 =head2 $case_sensitive
546 If true, SQL comparisons will be case-sensitive. Default is false;
548 =head2 $parenthesis_significant
550 If true, SQL comparison will preserve and report difference in nested
551 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
555 When L</eq_sql> returns false, the global variable
556 C<$sql_differ> contains the SQL portion
557 where a difference was encountered.
562 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
566 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
568 Norbert Buchmuller <norbi@nix.hu>
570 Peter Rabbitson <ribasushi@cpan.org>
572 =head1 COPYRIGHT AND LICENSE
574 Copyright 2008 by Laurent Dami.
576 This library is free software; you can redistribute it and/or modify
577 it under the same terms as Perl itself.