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;
24 # These SQL keywords always signal end of the current expression (except inside
25 # of a parenthesized subexpression).
26 # Format: A list of strings that will be compiled to extended syntax (ie.
27 # /.../x) regexes, without capturing parentheses. They will be automatically
28 # anchored to word boundaries to match the whole token).
29 my @expression_terminator_sql_keywords = (
33 (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
34 (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
51 my $tokenizer_re_str = join('|',
52 map { '\b' . $_ . '\b' }
53 @expression_terminator_sql_keywords, 'AND', 'OR'
56 my $tokenizer_re = qr/
69 sub is_same_sql_bind {
70 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
73 my $same_sql = eq_sql($sql1, $sql2);
74 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
76 # call Test::Builder::ok
77 my $ret = $tb->ok($same_sql && $same_bind, $msg);
81 _sql_differ_diag($sql1, $sql2);
84 _bind_differ_diag($bind_ref1, $bind_ref2);
87 # pass ok() result further
92 my ($sql1, $sql2, $msg) = @_;
95 my $same_sql = eq_sql($sql1, $sql2);
97 # call Test::Builder::ok
98 my $ret = $tb->ok($same_sql, $msg);
102 _sql_differ_diag($sql1, $sql2);
105 # pass ok() result further
110 my ($bind_ref1, $bind_ref2, $msg) = @_;
113 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
115 # call Test::Builder::ok
116 my $ret = $tb->ok($same_bind, $msg);
120 _bind_differ_diag($bind_ref1, $bind_ref2);
123 # pass ok() result further
127 sub _sql_differ_diag {
128 my ($sql1, $sql2) = @_;
130 $tb->diag("SQL expressions differ\n"
133 ."differing in :\n$sql_differ\n"
137 sub _bind_differ_diag {
138 my ($bind_ref1, $bind_ref2) = @_;
140 $tb->diag("BIND values differ\n"
141 ." got: " . Dumper($bind_ref1)
142 ."expected: " . Dumper($bind_ref2)
147 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
149 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
154 my ($bind_ref1, $bind_ref2) = @_;
156 return eq_deeply($bind_ref1, $bind_ref2);
160 my ($sql1, $sql2) = @_;
163 my $tree1 = parse($sql1);
164 my $tree2 = parse($sql2);
166 return _eq_sql($tree1, $tree2);
170 my ($left, $right) = @_;
172 # ignore top-level parentheses
173 while ($left and $left->[0] and $left->[0] eq 'PAREN') {$left = $left->[1]}
174 while ($right and $right->[0] and $right->[0] eq 'PAREN') {$right = $right->[1]}
176 # one is defined the other not
177 if ( (defined $left) xor (defined $right) ) {
180 # one is undefined, then so is the other
181 elsif (not defined $left) {
184 # if operators are different
185 elsif ($left->[0] ne $right->[0]) {
186 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
191 # elsif operators are identical, compare operands
193 if ($left->[0] eq 'EXPR' ) { # unary operator
194 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
195 (my $r = " $right->[1] ") =~ s/\s+/ /g;
196 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
197 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
200 else { # binary operator
201 return _eq_sql($left->[1][0], $right->[1][0]) # left operand
202 && _eq_sql($left->[1][1], $right->[1][1]); # right operand
211 # tokenize string, and remove all optional whitespace
213 foreach my $token (split $tokenizer_re, $s) {
215 $token =~ s/\s+([^\w\s])/$1/g;
216 $token =~ s/([^\w\s])\s+/$1/g;
217 push @$tokens, $token if $token !~ /^$/;
220 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
225 my ($tokens, $state) = @_;
228 while (1) { # left-associative parsing
230 my $lookahead = $tokens->[0];
231 return $left if !defined($lookahead)
232 || ($state == PARSE_IN_PARENS && $lookahead eq ')')
233 || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi }
234 '\)', @expression_terminator_sql_keywords
237 my $token = shift @$tokens;
239 # nested expression in ()
241 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
242 $token = shift @$tokens or croak "missing ')'";
243 $token eq ')' or croak "unexpected token : $token";
244 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
248 elsif ($token eq 'AND' || $token eq 'OR') {
249 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
250 $left = [$token => [$left, $right]];
252 # expression terminator keywords (as they start a new expression)
253 elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) {
254 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
255 $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]]
256 : [CONCAT => [[EXPR => $token], [PAREN => $right]]];
260 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
271 EXPR => sub {$tree->[1] },
272 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
273 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
274 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
275 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
277 $dispatch->{$tree->[0]}->();
288 SQL::Abstract::Test - Helper function for testing SQL::Abstract
294 use SQL::Abstract::Test import => [qw/
295 is_same_sql_bind is_same_sql is_same_bind
296 eq_sql_bind eq_sql eq_bind
299 my ($sql, @bind) = SQL::Abstract->new->select(%args);
301 is_same_sql_bind($given_sql, \@given_bind,
302 $expected_sql, \@expected_bind, $test_msg);
304 is_same_sql($given_sql, $expected_sql, $test_msg);
305 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
307 my $is_same = eq_sql_bind($given_sql, \@given_bind,
308 $expected_sql, \@expected_bind);
310 my $sql_same = eq_sql($given_sql, $expected_sql);
311 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
315 This module is only intended for authors of tests on
316 L<SQL::Abstract|SQL::Abstract> and related modules;
317 it exports functions for comparing two SQL statements
318 and their bound values.
320 The SQL comparison is performed on I<abstract syntax>,
321 ignoring differences in spaces or in levels of parentheses.
322 Therefore the tests will pass as long as the semantics
323 is preserved, even if the surface syntax has changed.
325 B<Disclaimer> : this is only a half-cooked semantic equivalence;
326 parsing is simple-minded, and comparison of SQL abstract syntax trees
327 ignores commutativity or associativity of AND/OR operators, Morgan
332 =head2 is_same_sql_bind
334 is_same_sql_bind($given_sql, \@given_bind,
335 $expected_sql, \@expected_bind, $test_msg);
337 Compares given and expected pairs of C<($sql, \@bind)>, and calls
338 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
339 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
340 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
341 L</is_same_bind>) that needs to be imported.
345 is_same_sql($given_sql, $expected_sql, $test_msg);
347 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
348 the result, with C<$test_msg> as message. If the test fails, a detailed
349 diagnostic is printed. For clients which use L<Test::More>, this is the one of
350 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
351 that needs to be imported.
355 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
357 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
358 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
359 is printed. For clients which use L<Test::More>, this is the one of the three
360 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
365 my $is_same = eq_sql_bind($given_sql, \@given_bind,
366 $expected_sql, \@expected_bind);
368 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
369 L</is_same_sql_bind>, but it just returns a boolean value and does not print
370 diagnostics or talk to L<Test::Builder>.
374 my $is_same = eq_sql($given_sql, $expected_sql);
376 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
377 but it just returns a boolean value and does not print diagnostics or talk to
378 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
379 will contain the SQL portion where a difference was encountered; this is useful
380 for printing diagnostics.
384 my $is_same = eq_sql(\@given_bind, \@expected_bind);
386 Compares two lists of bind values, taking into account the fact that some of
387 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
388 L</is_same_bind>, but it just returns a boolean value and does not print
389 diagnostics or talk to L<Test::Builder>.
391 =head1 GLOBAL VARIABLES
393 =head2 $case_sensitive
395 If true, SQL comparisons will be case-sensitive. Default is false;
399 When L</eq_sql> returns false, the global variable
400 C<$sql_differ> contains the SQL portion
401 where a difference was encountered.
406 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
410 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
412 Norbert Buchmuller <norbi@nix.hu>
414 =head1 COPYRIGHT AND LICENSE
416 Copyright 2008 by Laurent Dami.
418 This library is free software; you can redistribute it and/or modify
419 it under the same terms as Perl itself.