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()
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 = (
35 (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
36 (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
53 my $tokenizer_re_str = join('|',
54 map { '\b' . $_ . '\b' }
55 @expression_terminator_sql_keywords, 'AND', 'OR'
58 my $tokenizer_re = qr/
71 sub is_same_sql_bind {
72 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
75 my $same_sql = eq_sql($sql1, $sql2);
76 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
78 # call Test::Builder::ok
79 $tb->ok($same_sql && $same_bind, $msg);
83 _sql_differ_diag($sql1, $sql2);
86 _bind_differ_diag($bind_ref1, $bind_ref2);
91 my ($sql1, $sql2, $msg) = @_;
94 my $same_sql = eq_sql($sql1, $sql2);
96 # call Test::Builder::ok
97 $tb->ok($same_sql, $msg);
101 _sql_differ_diag($sql1, $sql2);
106 my ($bind_ref1, $bind_ref2, $msg) = @_;
109 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
111 # call Test::Builder::ok
112 $tb->ok($same_bind, $msg);
116 _bind_differ_diag($bind_ref1, $bind_ref2);
120 sub _sql_differ_diag {
121 my ($sql1, $sql2) = @_;
123 $tb->diag("SQL expressions differ\n"
126 ."differing in :\n$sql_differ\n"
130 sub _bind_differ_diag {
131 my ($bind_ref1, $bind_ref2) = @_;
133 $tb->diag("BIND values differ\n"
134 ." got: " . Dumper($bind_ref1)
135 ."expected: " . Dumper($bind_ref2)
140 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
142 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
147 my ($bind_ref1, $bind_ref2) = @_;
149 return eq_deeply($bind_ref1, $bind_ref2);
153 my ($sql1, $sql2) = @_;
156 my $tree1 = parse($sql1);
157 my $tree2 = parse($sql2);
159 return _eq_sql($tree1, $tree2);
163 my ($left, $right) = @_;
165 # ignore top-level parentheses
166 while ($left->[0] eq 'PAREN') {$left = $left->[1] }
167 while ($right->[0] eq 'PAREN') {$right = $right->[1]}
169 # if operators are different
170 if ($left->[0] ne $right->[0]) {
171 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
176 # elsif operators are identical, compare operands
178 if ($left->[0] eq 'EXPR' ) { # unary operator
179 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
180 (my $r = " $right->[1] ") =~ s/\s+/ /g;
181 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
182 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
185 else { # binary operator
186 return _eq_sql($left->[1][0], $right->[1][0]) # left operand
187 && _eq_sql($left->[1][1], $right->[1][1]); # right operand
196 # tokenize string, and remove all optional whitespace
198 foreach my $token (split $tokenizer_re, $s) {
200 $token =~ s/\s+([^\w\s])/$1/g;
201 $token =~ s/([^\w\s])\s+/$1/g;
202 push @$tokens, $token if $token !~ /^$/;
205 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
210 my ($tokens, $state) = @_;
213 while (1) { # left-associative parsing
215 my $lookahead = $tokens->[0];
216 return $left if !defined($lookahead)
217 || ($state == PARSE_IN_PARENS && $lookahead eq ')')
218 || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi }
219 '\)', @expression_terminator_sql_keywords
222 my $token = shift @$tokens;
224 # nested expression in ()
226 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
227 $token = shift @$tokens or croak "missing ')'";
228 $token eq ')' or croak "unexpected token : $token";
229 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
233 elsif ($token eq 'AND' || $token eq 'OR') {
234 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
235 $left = [$token => [$left, $right]];
237 # expression terminator keywords (as they start a new expression)
238 elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) {
239 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
240 $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]]
241 : [CONCAT => [[EXPR => $token], [PAREN => $right]]];
245 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
256 EXPR => sub {$tree->[1] },
257 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
258 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
259 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
260 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
262 $dispatch->{$tree->[0]}->();
273 SQL::Abstract::Test - Helper function for testing SQL::Abstract
279 use SQL::Abstract::Test import => [qw/
280 is_same_sql_bind is_same_sql is_same_bind
281 eq_sql_bind eq_sql eq_bind
284 my ($sql, @bind) = SQL::Abstract->new->select(%args);
286 is_same_sql_bind($given_sql, \@given_bind,
287 $expected_sql, \@expected_bind, $test_msg);
289 is_same_sql($given_sql, $expected_sql, $test_msg);
290 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
292 my $is_same = eq_sql_bind($given_sql, \@given_bind,
293 $expected_sql, \@expected_bind);
295 my $sql_same = eq_sql($given_sql, $expected_sql);
296 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
300 This module is only intended for authors of tests on
301 L<SQL::Abstract|SQL::Abstract> and related modules;
302 it exports functions for comparing two SQL statements
303 and their bound values.
305 The SQL comparison is performed on I<abstract syntax>,
306 ignoring differences in spaces or in levels of parentheses.
307 Therefore the tests will pass as long as the semantics
308 is preserved, even if the surface syntax has changed.
310 B<Disclaimer> : this is only a half-cooked semantic equivalence;
311 parsing is simple-minded, and comparison of SQL abstract syntax trees
312 ignores commutativity or associativity of AND/OR operators, Morgan
317 =head2 is_same_sql_bind
319 is_same_sql_bind($given_sql, \@given_bind,
320 $expected_sql, \@expected_bind, $test_msg);
322 Compares given and expected pairs of C<($sql, \@bind)>, and calls
323 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
324 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
325 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
326 L</is_same_bind>) that needs to be imported.
330 is_same_sql($given_sql, $expected_sql, $test_msg);
332 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
333 the result, with C<$test_msg> as message. If the test fails, a detailed
334 diagnostic is printed. For clients which use L<Test::More>, this is the one of
335 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
336 that needs to be imported.
340 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
342 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
343 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
344 is printed. For clients which use L<Test::More>, this is the one of the three
345 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
350 my $is_same = eq_sql_bind($given_sql, \@given_bind,
351 $expected_sql, \@expected_bind);
353 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
354 L</is_same_sql_bind>, but it just returns a boolean value and does not print
355 diagnostics or talk to L<Test::Builder>.
359 my $is_same = eq_sql($given_sql, $expected_sql);
361 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
362 but it just returns a boolean value and does not print diagnostics or talk to
363 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
364 will contain the SQL portion where a difference was encountered; this is useful
365 for printing diagnostics.
369 my $is_same = eq_sql(\@given_bind, \@expected_bind);
371 Compares two lists of bind values, taking into account the fact that some of
372 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
373 L</is_same_bind>, but it just returns a boolean value and does not print
374 diagnostics or talk to L<Test::Builder>.
376 =head1 GLOBAL VARIABLES
378 =head2 $case_sensitive
380 If true, SQL comparisons will be case-sensitive. Default is false;
384 When L</eq_sql> returns false, the global variable
385 C<$sql_differ> contains the SQL portion
386 where a difference was encountered.
391 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
395 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
397 Norbert Buchmuller <norbi@nix.hu>
399 =head1 COPYRIGHT AND LICENSE
401 Copyright 2008 by Laurent Dami.
403 This library is free software; you can redistribute it and/or modify
404 it under the same terms as Perl itself.