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 $tb->ok($same_sql && $same_bind, $msg);
81 _sql_differ_diag($sql1, $sql2);
84 _bind_differ_diag($bind_ref1, $bind_ref2);
89 my ($sql1, $sql2, $msg) = @_;
92 my $same_sql = eq_sql($sql1, $sql2);
94 # call Test::Builder::ok
95 $tb->ok($same_sql, $msg);
99 _sql_differ_diag($sql1, $sql2);
104 my ($bind_ref1, $bind_ref2, $msg) = @_;
107 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
109 # call Test::Builder::ok
110 $tb->ok($same_bind, $msg);
114 _bind_differ_diag($bind_ref1, $bind_ref2);
118 sub _sql_differ_diag {
119 my ($sql1, $sql2) = @_;
121 $tb->diag("SQL expressions differ\n"
124 ."differing in :\n$sql_differ\n"
128 sub _bind_differ_diag {
129 my ($bind_ref1, $bind_ref2) = @_;
131 $tb->diag("BIND values differ\n"
132 ." got: " . Dumper($bind_ref1)
133 ."expected: " . Dumper($bind_ref2)
138 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
140 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
145 my ($bind_ref1, $bind_ref2) = @_;
147 return eq_deeply($bind_ref1, $bind_ref2);
151 my ($sql1, $sql2) = @_;
154 my $tree1 = parse($sql1);
155 my $tree2 = parse($sql2);
157 return _eq_sql($tree1, $tree2);
161 my ($left, $right) = @_;
163 # ignore top-level parentheses
164 while ($left and $left->[0] and $left->[0] eq 'PAREN') {$left = $left->[1]}
165 while ($right and $right->[0] and $right->[0] eq 'PAREN') {$right = $right->[1]}
167 # one is defined the other not
168 if ( (defined $left) xor (defined $right) ) {
171 # one is undefined, then so is the other
172 elsif (not defined $left) {
175 # if operators are different
176 elsif ($left->[0] ne $right->[0]) {
177 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
182 # elsif operators are identical, compare operands
184 if ($left->[0] eq 'EXPR' ) { # unary operator
185 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
186 (my $r = " $right->[1] ") =~ s/\s+/ /g;
187 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
188 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
191 else { # binary operator
192 return _eq_sql($left->[1][0], $right->[1][0]) # left operand
193 && _eq_sql($left->[1][1], $right->[1][1]); # right operand
202 # tokenize string, and remove all optional whitespace
204 foreach my $token (split $tokenizer_re, $s) {
206 $token =~ s/\s+([^\w\s])/$1/g;
207 $token =~ s/([^\w\s])\s+/$1/g;
208 push @$tokens, $token if $token !~ /^$/;
211 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
216 my ($tokens, $state) = @_;
219 while (1) { # left-associative parsing
221 my $lookahead = $tokens->[0];
222 return $left if !defined($lookahead)
223 || ($state == PARSE_IN_PARENS && $lookahead eq ')')
224 || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi }
225 '\)', @expression_terminator_sql_keywords
228 my $token = shift @$tokens;
230 # nested expression in ()
232 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
233 $token = shift @$tokens or croak "missing ')'";
234 $token eq ')' or croak "unexpected token : $token";
235 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
239 elsif ($token eq 'AND' || $token eq 'OR') {
240 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
241 $left = [$token => [$left, $right]];
243 # expression terminator keywords (as they start a new expression)
244 elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) {
245 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
246 $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]]
247 : [CONCAT => [[EXPR => $token], [PAREN => $right]]];
251 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
262 EXPR => sub {$tree->[1] },
263 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
264 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
265 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
266 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
268 $dispatch->{$tree->[0]}->();
279 SQL::Abstract::Test - Helper function for testing SQL::Abstract
285 use SQL::Abstract::Test import => [qw/
286 is_same_sql_bind is_same_sql is_same_bind
287 eq_sql_bind eq_sql eq_bind
290 my ($sql, @bind) = SQL::Abstract->new->select(%args);
292 is_same_sql_bind($given_sql, \@given_bind,
293 $expected_sql, \@expected_bind, $test_msg);
295 is_same_sql($given_sql, $expected_sql, $test_msg);
296 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
298 my $is_same = eq_sql_bind($given_sql, \@given_bind,
299 $expected_sql, \@expected_bind);
301 my $sql_same = eq_sql($given_sql, $expected_sql);
302 my $bind_same = eq_bind(\@given_bind, \@expected_bind);
306 This module is only intended for authors of tests on
307 L<SQL::Abstract|SQL::Abstract> and related modules;
308 it exports functions for comparing two SQL statements
309 and their bound values.
311 The SQL comparison is performed on I<abstract syntax>,
312 ignoring differences in spaces or in levels of parentheses.
313 Therefore the tests will pass as long as the semantics
314 is preserved, even if the surface syntax has changed.
316 B<Disclaimer> : this is only a half-cooked semantic equivalence;
317 parsing is simple-minded, and comparison of SQL abstract syntax trees
318 ignores commutativity or associativity of AND/OR operators, Morgan
323 =head2 is_same_sql_bind
325 is_same_sql_bind($given_sql, \@given_bind,
326 $expected_sql, \@expected_bind, $test_msg);
328 Compares given and expected pairs of C<($sql, \@bind)>, and calls
329 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
330 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
331 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
332 L</is_same_bind>) that needs to be imported.
336 is_same_sql($given_sql, $expected_sql, $test_msg);
338 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
339 the result, with C<$test_msg> as message. If the test fails, a detailed
340 diagnostic is printed. For clients which use L<Test::More>, this is the one of
341 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
342 that needs to be imported.
346 is_same_bind(\@given_bind, \@expected_bind, $test_msg);
348 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
349 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
350 is printed. For clients which use L<Test::More>, this is the one of the three
351 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
356 my $is_same = eq_sql_bind($given_sql, \@given_bind,
357 $expected_sql, \@expected_bind);
359 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
360 L</is_same_sql_bind>, but it just returns a boolean value and does not print
361 diagnostics or talk to L<Test::Builder>.
365 my $is_same = eq_sql($given_sql, $expected_sql);
367 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
368 but it just returns a boolean value and does not print diagnostics or talk to
369 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
370 will contain the SQL portion where a difference was encountered; this is useful
371 for printing diagnostics.
375 my $is_same = eq_sql(\@given_bind, \@expected_bind);
377 Compares two lists of bind values, taking into account the fact that some of
378 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
379 L</is_same_bind>, but it just returns a boolean value and does not print
380 diagnostics or talk to L<Test::Builder>.
382 =head1 GLOBAL VARIABLES
384 =head2 $case_sensitive
386 If true, SQL comparisons will be case-sensitive. Default is false;
390 When L</eq_sql> returns false, the global variable
391 C<$sql_differ> contains the SQL portion
392 where a difference was encountered.
397 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
401 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
403 Norbert Buchmuller <norbi@nix.hu>
405 =head1 COPYRIGHT AND LICENSE
407 Copyright 2008 by Laurent Dami.
409 This library is free software; you can redistribute it and/or modify
410 it under the same terms as Perl itself.