Commit | Line | Data |
fffe6900 |
1 | package SQL::Abstract::Test; # see doc at end of file |
2 | |
3 | use strict; |
4 | use warnings; |
5aad8cf3 |
5 | use base qw/Test::Builder::Module Exporter/; |
fffe6900 |
6 | use Data::Dumper; |
7 | use Carp; |
4abea32b |
8 | use Test::Builder; |
9 | use Test::Deep qw(eq_deeply); |
fffe6900 |
10 | |
e7827ba2 |
11 | our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind |
12 | &eq_sql_bind &eq_sql &eq_bind |
fffe6900 |
13 | $case_sensitive $sql_differ/; |
14 | |
15 | our $case_sensitive = 0; |
16 | our $sql_differ; # keeps track of differing portion between SQLs |
5aad8cf3 |
17 | our $tb = __PACKAGE__->builder; |
fffe6900 |
18 | |
25823711 |
19 | # Parser states for _recurse_parse() |
5221d7fc |
20 | use constant PARSE_IN_EXPR => 1; |
21 | use constant PARSE_IN_PARENS => 2; |
1b17d1b0 |
22 | use constant PARSE_TOP_LEVEL => 3; |
25823711 |
23 | |
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 = ( |
1b17d1b0 |
30 | 'SELECT', |
25823711 |
31 | 'FROM', |
32 | '(?: |
33 | (?: |
34 | (?: \b (?: LEFT | RIGHT | FULL ) \s+ )? |
35 | (?: \b (?: CROSS | INNER | OUTER ) \s+ )? |
36 | )? |
37 | JOIN |
38 | )', |
39 | 'ON', |
40 | 'WHERE', |
41 | 'GROUP \s+ BY', |
42 | 'HAVING', |
43 | 'ORDER \s+ BY', |
44 | 'LIMIT', |
45 | 'OFFSET', |
46 | 'FOR', |
47 | 'UNION', |
48 | 'INTERSECT', |
49 | 'EXCEPT', |
50 | ); |
51 | |
35149895 |
52 | # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics |
1b17d1b0 |
53 | my @unrollable_sql_keywords = ( |
54 | 'ON', |
55 | 'WHERE', |
56 | 'GROUP \s+ BY', |
57 | 'HAVING', |
58 | 'ORDER \s+ BY', |
59 | ); |
60 | |
25823711 |
61 | my $tokenizer_re_str = join('|', |
62 | map { '\b' . $_ . '\b' } |
63 | @expression_terminator_sql_keywords, 'AND', 'OR' |
64 | ); |
65 | |
66 | my $tokenizer_re = qr/ |
67 | \s* |
68 | ( |
69 | \( |
70 | | |
71 | \) |
72 | | |
73 | $tokenizer_re_str |
74 | ) |
75 | \s* |
76 | /xi; |
77 | |
1b17d1b0 |
78 | my $unrollable_re_str = join ('|', map { $_ } @unrollable_sql_keywords); |
79 | my $unrollable_re = qr/^ (?: $unrollable_re_str ) $/ix; |
80 | |
25823711 |
81 | |
fffe6900 |
82 | sub is_same_sql_bind { |
83 | my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; |
84 | |
85 | # compare |
25823711 |
86 | my $same_sql = eq_sql($sql1, $sql2); |
fffe6900 |
87 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
88 | |
a6daa642 |
89 | # call Test::Builder::ok |
1a828f61 |
90 | my $ret = $tb->ok($same_sql && $same_bind, $msg); |
fffe6900 |
91 | |
92 | # add debugging info |
93 | if (!$same_sql) { |
e7827ba2 |
94 | _sql_differ_diag($sql1, $sql2); |
fffe6900 |
95 | } |
96 | if (!$same_bind) { |
e7827ba2 |
97 | _bind_differ_diag($bind_ref1, $bind_ref2); |
fffe6900 |
98 | } |
1a828f61 |
99 | |
100 | # pass ok() result further |
101 | return $ret; |
fffe6900 |
102 | } |
103 | |
e7827ba2 |
104 | sub is_same_sql { |
105 | my ($sql1, $sql2, $msg) = @_; |
106 | |
107 | # compare |
108 | my $same_sql = eq_sql($sql1, $sql2); |
109 | |
110 | # call Test::Builder::ok |
1a828f61 |
111 | my $ret = $tb->ok($same_sql, $msg); |
e7827ba2 |
112 | |
113 | # add debugging info |
114 | if (!$same_sql) { |
115 | _sql_differ_diag($sql1, $sql2); |
116 | } |
1a828f61 |
117 | |
118 | # pass ok() result further |
119 | return $ret; |
e7827ba2 |
120 | } |
121 | |
122 | sub is_same_bind { |
123 | my ($bind_ref1, $bind_ref2, $msg) = @_; |
124 | |
125 | # compare |
126 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
127 | |
128 | # call Test::Builder::ok |
1a828f61 |
129 | my $ret = $tb->ok($same_bind, $msg); |
e7827ba2 |
130 | |
131 | # add debugging info |
132 | if (!$same_bind) { |
133 | _bind_differ_diag($bind_ref1, $bind_ref2); |
134 | } |
1a828f61 |
135 | |
136 | # pass ok() result further |
137 | return $ret; |
e7827ba2 |
138 | } |
139 | |
140 | sub _sql_differ_diag { |
141 | my ($sql1, $sql2) = @_; |
142 | |
143 | $tb->diag("SQL expressions differ\n" |
144 | ." got: $sql1\n" |
145 | ."expected: $sql2\n" |
146 | ."differing in :\n$sql_differ\n" |
147 | ); |
148 | } |
149 | |
150 | sub _bind_differ_diag { |
151 | my ($bind_ref1, $bind_ref2) = @_; |
152 | |
153 | $tb->diag("BIND values differ\n" |
154 | ." got: " . Dumper($bind_ref1) |
155 | ."expected: " . Dumper($bind_ref2) |
156 | ); |
157 | } |
158 | |
159 | sub eq_sql_bind { |
160 | my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_; |
161 | |
162 | return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); |
163 | } |
164 | |
165 | |
fffe6900 |
166 | sub eq_bind { |
167 | my ($bind_ref1, $bind_ref2) = @_; |
fffe6900 |
168 | |
4abea32b |
169 | return eq_deeply($bind_ref1, $bind_ref2); |
fffe6900 |
170 | } |
171 | |
172 | sub eq_sql { |
25823711 |
173 | my ($sql1, $sql2) = @_; |
174 | |
175 | # parse |
176 | my $tree1 = parse($sql1); |
177 | my $tree2 = parse($sql2); |
178 | |
1b17d1b0 |
179 | return 1 if _eq_sql($tree1, $tree2); |
25823711 |
180 | } |
181 | |
182 | sub _eq_sql { |
fffe6900 |
183 | my ($left, $right) = @_; |
184 | |
939db550 |
185 | # one is defined the other not |
186 | if ( (defined $left) xor (defined $right) ) { |
187 | return 0; |
188 | } |
189 | # one is undefined, then so is the other |
190 | elsif (not defined $left) { |
d15c14cc |
191 | return 1; |
192 | } |
1b17d1b0 |
193 | # one is a list, the other is an op with a list |
194 | elsif (ref $left->[0] xor ref $right->[0]) { |
195 | $sql_differ = sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ); |
fffe6900 |
196 | return 0; |
197 | } |
1b17d1b0 |
198 | # one is a list, so is the other |
199 | elsif (ref $left->[0]) { |
200 | for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) { |
201 | return 0 if (not _eq_sql ($left->[$i], $right->[$i]) ); |
202 | } |
203 | return 1; |
204 | } |
205 | # both are an op-list combo |
206 | else { |
207 | |
208 | for ($left, $right) { |
209 | |
210 | next unless (ref $_->[1]); |
211 | |
212 | # unroll parenthesis in an elaborate loop |
213 | my $changes; |
214 | do { |
215 | |
216 | my @children; |
217 | $changes = 0; |
218 | |
219 | for my $child (@{$_->[1]}) { |
220 | if (not ref $child or not $child->[0] eq 'PAREN') { |
221 | push @children, $child; |
222 | next; |
223 | } |
224 | |
225 | # unroll nested parenthesis |
226 | while ($child->[1][0][0] eq 'PAREN') { |
227 | $child = $child->[1][0]; |
228 | $changes++; |
229 | } |
230 | |
231 | # if the parens are wrapped around an AND/OR matching the parent AND/OR - open the parens up and merge the list |
232 | if ( |
233 | ( $_->[0] eq 'AND' or $_->[0] eq 'OR') |
234 | and |
235 | $child->[1][0][0] eq $_->[0] |
236 | ) { |
237 | push @children, @{$child->[1][0][1]}; |
238 | $changes++; |
239 | } |
240 | |
241 | # if the parent operator explcitly allows it, or if parents are wrapped around an expression just nuke them |
242 | elsif ( $child->[1][0][0] eq 'EXPR' or $_->[0] =~ $unrollable_re ) { |
243 | push @children, $child->[1][0]; |
244 | $changes++; |
245 | } |
246 | |
247 | # otherwise no more mucking |
248 | else { |
249 | push @children, $child; |
250 | } |
251 | } |
252 | |
253 | $_->[1] = \@children; |
254 | } while ($changes); |
fffe6900 |
255 | } |
1b17d1b0 |
256 | |
257 | # if operators are different |
258 | if ($left->[0] ne $right->[0]) { |
259 | $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", |
260 | unparse($left), |
261 | unparse($right); |
262 | return 0; |
263 | } |
264 | # elsif operators are identical, compare operands |
265 | else { |
266 | if ($left->[0] eq 'EXPR' ) { # unary operator |
267 | (my $l = " $left->[1] " ) =~ s/\s+/ /g; |
268 | (my $r = " $right->[1] ") =~ s/\s+/ /g; |
269 | my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r); |
270 | $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq; |
271 | return $eq; |
272 | } |
273 | else { |
274 | my $eq = _eq_sql($left->[1], $right->[1]); |
275 | $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq; |
276 | return $eq; |
277 | } |
fffe6900 |
278 | } |
279 | } |
280 | } |
281 | |
282 | |
283 | sub parse { |
284 | my $s = shift; |
285 | |
25823711 |
286 | # tokenize string, and remove all optional whitespace |
287 | my $tokens = []; |
288 | foreach my $token (split $tokenizer_re, $s) { |
289 | $token =~ s/\s+/ /g; |
290 | $token =~ s/\s+([^\w\s])/$1/g; |
291 | $token =~ s/([^\w\s])\s+/$1/g; |
292 | push @$tokens, $token if $token !~ /^$/; |
293 | } |
fffe6900 |
294 | |
25823711 |
295 | my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL); |
fffe6900 |
296 | return $tree; |
297 | } |
298 | |
299 | sub _recurse_parse { |
25823711 |
300 | my ($tokens, $state) = @_; |
fffe6900 |
301 | |
302 | my $left; |
303 | while (1) { # left-associative parsing |
304 | |
305 | my $lookahead = $tokens->[0]; |
1b17d1b0 |
306 | if ( not defined($lookahead) |
307 | or |
308 | ($state == PARSE_IN_PARENS && $lookahead eq ')') |
309 | or |
310 | ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords) ) |
311 | ) { |
312 | |
313 | return $left; |
314 | return ($state == PARSE_TOP_LEVEL |
315 | ? $left->[0] |
316 | : $left |
317 | ); |
318 | } |
fffe6900 |
319 | |
320 | my $token = shift @$tokens; |
321 | |
322 | # nested expression in () |
323 | if ($token eq '(') { |
25823711 |
324 | my $right = _recurse_parse($tokens, PARSE_IN_PARENS); |
fffe6900 |
325 | $token = shift @$tokens or croak "missing ')'"; |
326 | $token eq ')' or croak "unexpected token : $token"; |
1b17d1b0 |
327 | $left = $left ? [@$left, [PAREN => [$right] ]] |
328 | : [PAREN => [$right] ]; |
fffe6900 |
329 | } |
1b17d1b0 |
330 | # AND/OR |
331 | elsif ($token =~ /^ (?: OR | AND ) $/xi ) { |
332 | my $op = uc $token; |
25823711 |
333 | my $right = _recurse_parse($tokens, PARSE_IN_EXPR); |
1b17d1b0 |
334 | |
335 | # Merge chunks if logic matches |
336 | if (ref $right and $op eq $right->[0]) { |
337 | $left = [ (shift @$right ), [$left, map { @$_ } @$right] ]; |
338 | } |
339 | else { |
340 | $left = [$op => [$left, $right]]; |
341 | } |
fffe6900 |
342 | } |
25823711 |
343 | # expression terminator keywords (as they start a new expression) |
1b17d1b0 |
344 | elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) { |
345 | my $op = uc $token; |
25823711 |
346 | my $right = _recurse_parse($tokens, PARSE_IN_EXPR); |
1b17d1b0 |
347 | $left = $left ? [@$left, [$op => [$right] ]] |
348 | : [ [$op => [$right] ] ]; |
25823711 |
349 | } |
fffe6900 |
350 | # leaf expression |
351 | else { |
1b17d1b0 |
352 | $left = $left ? [@$left, [EXPR => $token] ] |
353 | : [ EXPR => $token ]; |
fffe6900 |
354 | } |
355 | } |
356 | } |
357 | |
358 | |
359 | |
360 | sub unparse { |
361 | my $tree = shift; |
1b17d1b0 |
362 | |
363 | if (not $tree ) { |
364 | return ''; |
365 | } |
366 | elsif (ref $tree->[0]) { |
367 | return join (" ", map { unparse ($_) } @$tree); |
368 | } |
369 | elsif ($tree->[0] eq 'EXPR') { |
370 | return $tree->[1]; |
371 | } |
372 | elsif ($tree->[0] eq 'PAREN') { |
373 | return sprintf '( %s )', join (" ", map {unparse($_)} @{$tree->[1]}); |
374 | } |
375 | elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND') { |
376 | return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]}); |
377 | } |
378 | else { |
379 | return sprintf '%s %s', $tree->[0], unparse ($tree->[1]); |
380 | } |
fffe6900 |
381 | } |
382 | |
383 | |
384 | 1; |
385 | |
386 | |
387 | __END__ |
388 | |
389 | =head1 NAME |
390 | |
391 | SQL::Abstract::Test - Helper function for testing SQL::Abstract |
392 | |
393 | =head1 SYNOPSIS |
394 | |
395 | use SQL::Abstract; |
396 | use Test::More; |
e7827ba2 |
397 | use SQL::Abstract::Test import => [qw/ |
398 | is_same_sql_bind is_same_sql is_same_bind |
399 | eq_sql_bind eq_sql eq_bind |
400 | /]; |
fffe6900 |
401 | |
402 | my ($sql, @bind) = SQL::Abstract->new->select(%args); |
e7827ba2 |
403 | |
fffe6900 |
404 | is_same_sql_bind($given_sql, \@given_bind, |
405 | $expected_sql, \@expected_bind, $test_msg); |
406 | |
e7827ba2 |
407 | is_same_sql($given_sql, $expected_sql, $test_msg); |
408 | is_same_bind(\@given_bind, \@expected_bind, $test_msg); |
409 | |
410 | my $is_same = eq_sql_bind($given_sql, \@given_bind, |
411 | $expected_sql, \@expected_bind); |
412 | |
413 | my $sql_same = eq_sql($given_sql, $expected_sql); |
414 | my $bind_same = eq_bind(\@given_bind, \@expected_bind); |
415 | |
fffe6900 |
416 | =head1 DESCRIPTION |
417 | |
418 | This module is only intended for authors of tests on |
419 | L<SQL::Abstract|SQL::Abstract> and related modules; |
420 | it exports functions for comparing two SQL statements |
421 | and their bound values. |
422 | |
423 | The SQL comparison is performed on I<abstract syntax>, |
424 | ignoring differences in spaces or in levels of parentheses. |
425 | Therefore the tests will pass as long as the semantics |
426 | is preserved, even if the surface syntax has changed. |
427 | |
428 | B<Disclaimer> : this is only a half-cooked semantic equivalence; |
429 | parsing is simple-minded, and comparison of SQL abstract syntax trees |
430 | ignores commutativity or associativity of AND/OR operators, Morgan |
431 | laws, etc. |
432 | |
433 | =head1 FUNCTIONS |
434 | |
435 | =head2 is_same_sql_bind |
436 | |
437 | is_same_sql_bind($given_sql, \@given_bind, |
438 | $expected_sql, \@expected_bind, $test_msg); |
439 | |
440 | Compares given and expected pairs of C<($sql, \@bind)>, and calls |
e7827ba2 |
441 | L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test |
442 | fails, a detailed diagnostic is printed. For clients which use L<Test::More>, |
443 | this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>, |
444 | L</is_same_bind>) that needs to be imported. |
445 | |
446 | =head2 is_same_sql |
447 | |
448 | is_same_sql($given_sql, $expected_sql, $test_msg); |
449 | |
450 | Compares given and expected SQL statements, and calls L<Test::Builder/ok> on |
451 | the result, with C<$test_msg> as message. If the test fails, a detailed |
452 | diagnostic is printed. For clients which use L<Test::More>, this is the one of |
453 | the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) |
454 | that needs to be imported. |
455 | |
456 | =head2 is_same_bind |
457 | |
458 | is_same_bind(\@given_bind, \@expected_bind, $test_msg); |
459 | |
460 | Compares given and expected bind values, and calls L<Test::Builder/ok> on the |
461 | result, with C<$test_msg> as message. If the test fails, a detailed diagnostic |
462 | is printed. For clients which use L<Test::More>, this is the one of the three |
463 | functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs |
464 | to be imported. |
465 | |
466 | =head2 eq_sql_bind |
467 | |
468 | my $is_same = eq_sql_bind($given_sql, \@given_bind, |
469 | $expected_sql, \@expected_bind); |
470 | |
471 | Compares given and expected pairs of C<($sql, \@bind)>. Similar to |
472 | L</is_same_sql_bind>, but it just returns a boolean value and does not print |
473 | diagnostics or talk to L<Test::Builder>. |
fffe6900 |
474 | |
475 | =head2 eq_sql |
476 | |
477 | my $is_same = eq_sql($given_sql, $expected_sql); |
478 | |
e7827ba2 |
479 | Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>, |
480 | but it just returns a boolean value and does not print diagnostics or talk to |
481 | L<Test::Builder>. If the result is false, the global variable L</$sql_differ> |
482 | will contain the SQL portion where a difference was encountered; this is useful |
483 | for printing diagnostics. |
fffe6900 |
484 | |
485 | =head2 eq_bind |
486 | |
487 | my $is_same = eq_sql(\@given_bind, \@expected_bind); |
488 | |
e7827ba2 |
489 | Compares two lists of bind values, taking into account the fact that some of |
490 | the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to |
491 | L</is_same_bind>, but it just returns a boolean value and does not print |
492 | diagnostics or talk to L<Test::Builder>. |
fffe6900 |
493 | |
494 | =head1 GLOBAL VARIABLES |
495 | |
e7827ba2 |
496 | =head2 $case_sensitive |
fffe6900 |
497 | |
498 | If true, SQL comparisons will be case-sensitive. Default is false; |
499 | |
e7827ba2 |
500 | =head2 $sql_differ |
fffe6900 |
501 | |
502 | When L</eq_sql> returns false, the global variable |
503 | C<$sql_differ> contains the SQL portion |
504 | where a difference was encountered. |
505 | |
506 | |
507 | =head1 SEE ALSO |
508 | |
a6daa642 |
509 | L<SQL::Abstract>, L<Test::More>, L<Test::Builder>. |
fffe6900 |
510 | |
25823711 |
511 | =head1 AUTHORS |
fffe6900 |
512 | |
513 | Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt> |
514 | |
25823711 |
515 | Norbert Buchmuller <norbi@nix.hu> |
516 | |
fffe6900 |
517 | =head1 COPYRIGHT AND LICENSE |
518 | |
519 | Copyright 2008 by Laurent Dami. |
520 | |
521 | This library is free software; you can redistribute it and/or modify |
522 | it under the same terms as Perl itself. |