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_TOP_LEVEL => 0; |
21 | use constant PARSE_IN_EXPR => 1; |
22 | use constant PARSE_IN_PARENS => 2; |
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 = ( |
30 | 'FROM', |
31 | '(?: |
32 | (?: |
33 | (?: \b (?: LEFT | RIGHT | FULL ) \s+ )? |
34 | (?: \b (?: CROSS | INNER | OUTER ) \s+ )? |
35 | )? |
36 | JOIN |
37 | )', |
38 | 'ON', |
39 | 'WHERE', |
40 | 'GROUP \s+ BY', |
41 | 'HAVING', |
42 | 'ORDER \s+ BY', |
43 | 'LIMIT', |
44 | 'OFFSET', |
45 | 'FOR', |
46 | 'UNION', |
47 | 'INTERSECT', |
48 | 'EXCEPT', |
49 | ); |
50 | |
51 | my $tokenizer_re_str = join('|', |
52 | map { '\b' . $_ . '\b' } |
53 | @expression_terminator_sql_keywords, 'AND', 'OR' |
54 | ); |
55 | |
56 | my $tokenizer_re = qr/ |
57 | \s* |
58 | ( |
59 | \( |
60 | | |
61 | \) |
62 | | |
63 | $tokenizer_re_str |
64 | ) |
65 | \s* |
66 | /xi; |
67 | |
68 | |
fffe6900 |
69 | sub is_same_sql_bind { |
70 | my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; |
71 | |
72 | # compare |
25823711 |
73 | my $same_sql = eq_sql($sql1, $sql2); |
fffe6900 |
74 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
75 | |
a6daa642 |
76 | # call Test::Builder::ok |
1a828f61 |
77 | my $ret = $tb->ok($same_sql && $same_bind, $msg); |
fffe6900 |
78 | |
79 | # add debugging info |
80 | if (!$same_sql) { |
e7827ba2 |
81 | _sql_differ_diag($sql1, $sql2); |
fffe6900 |
82 | } |
83 | if (!$same_bind) { |
e7827ba2 |
84 | _bind_differ_diag($bind_ref1, $bind_ref2); |
fffe6900 |
85 | } |
1a828f61 |
86 | |
87 | # pass ok() result further |
88 | return $ret; |
fffe6900 |
89 | } |
90 | |
e7827ba2 |
91 | sub is_same_sql { |
92 | my ($sql1, $sql2, $msg) = @_; |
93 | |
94 | # compare |
95 | my $same_sql = eq_sql($sql1, $sql2); |
96 | |
97 | # call Test::Builder::ok |
1a828f61 |
98 | my $ret = $tb->ok($same_sql, $msg); |
e7827ba2 |
99 | |
100 | # add debugging info |
101 | if (!$same_sql) { |
102 | _sql_differ_diag($sql1, $sql2); |
103 | } |
1a828f61 |
104 | |
105 | # pass ok() result further |
106 | return $ret; |
e7827ba2 |
107 | } |
108 | |
109 | sub is_same_bind { |
110 | my ($bind_ref1, $bind_ref2, $msg) = @_; |
111 | |
112 | # compare |
113 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
114 | |
115 | # call Test::Builder::ok |
1a828f61 |
116 | my $ret = $tb->ok($same_bind, $msg); |
e7827ba2 |
117 | |
118 | # add debugging info |
119 | if (!$same_bind) { |
120 | _bind_differ_diag($bind_ref1, $bind_ref2); |
121 | } |
1a828f61 |
122 | |
123 | # pass ok() result further |
124 | return $ret; |
e7827ba2 |
125 | } |
126 | |
127 | sub _sql_differ_diag { |
128 | my ($sql1, $sql2) = @_; |
129 | |
130 | $tb->diag("SQL expressions differ\n" |
131 | ." got: $sql1\n" |
132 | ."expected: $sql2\n" |
133 | ."differing in :\n$sql_differ\n" |
134 | ); |
135 | } |
136 | |
137 | sub _bind_differ_diag { |
138 | my ($bind_ref1, $bind_ref2) = @_; |
139 | |
140 | $tb->diag("BIND values differ\n" |
141 | ." got: " . Dumper($bind_ref1) |
142 | ."expected: " . Dumper($bind_ref2) |
143 | ); |
144 | } |
145 | |
146 | sub eq_sql_bind { |
147 | my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_; |
148 | |
149 | return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); |
150 | } |
151 | |
152 | |
fffe6900 |
153 | sub eq_bind { |
154 | my ($bind_ref1, $bind_ref2) = @_; |
fffe6900 |
155 | |
4abea32b |
156 | return eq_deeply($bind_ref1, $bind_ref2); |
fffe6900 |
157 | } |
158 | |
159 | sub eq_sql { |
25823711 |
160 | my ($sql1, $sql2) = @_; |
161 | |
162 | # parse |
163 | my $tree1 = parse($sql1); |
164 | my $tree2 = parse($sql2); |
165 | |
166 | return _eq_sql($tree1, $tree2); |
167 | } |
168 | |
169 | sub _eq_sql { |
fffe6900 |
170 | my ($left, $right) = @_; |
171 | |
172 | # ignore top-level parentheses |
939db550 |
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]} |
fffe6900 |
175 | |
939db550 |
176 | # one is defined the other not |
177 | if ( (defined $left) xor (defined $right) ) { |
178 | return 0; |
179 | } |
180 | # one is undefined, then so is the other |
181 | elsif (not defined $left) { |
d15c14cc |
182 | return 1; |
183 | } |
fffe6900 |
184 | # if operators are different |
939db550 |
185 | elsif ($left->[0] ne $right->[0]) { |
fffe6900 |
186 | $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", |
187 | unparse($left), |
188 | unparse($right); |
189 | return 0; |
190 | } |
191 | # elsif operators are identical, compare operands |
192 | else { |
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; |
198 | return $eq; |
199 | } |
200 | else { # binary operator |
25823711 |
201 | return _eq_sql($left->[1][0], $right->[1][0]) # left operand |
202 | && _eq_sql($left->[1][1], $right->[1][1]); # right operand |
fffe6900 |
203 | } |
204 | } |
205 | } |
206 | |
207 | |
208 | sub parse { |
209 | my $s = shift; |
210 | |
25823711 |
211 | # tokenize string, and remove all optional whitespace |
212 | my $tokens = []; |
213 | foreach my $token (split $tokenizer_re, $s) { |
214 | $token =~ s/\s+/ /g; |
215 | $token =~ s/\s+([^\w\s])/$1/g; |
216 | $token =~ s/([^\w\s])\s+/$1/g; |
217 | push @$tokens, $token if $token !~ /^$/; |
218 | } |
fffe6900 |
219 | |
25823711 |
220 | my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL); |
fffe6900 |
221 | return $tree; |
222 | } |
223 | |
224 | sub _recurse_parse { |
25823711 |
225 | my ($tokens, $state) = @_; |
fffe6900 |
226 | |
227 | my $left; |
228 | while (1) { # left-associative parsing |
229 | |
230 | my $lookahead = $tokens->[0]; |
25823711 |
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 |
235 | ); |
fffe6900 |
236 | |
237 | my $token = shift @$tokens; |
238 | |
239 | # nested expression in () |
240 | if ($token eq '(') { |
25823711 |
241 | my $right = _recurse_parse($tokens, PARSE_IN_PARENS); |
fffe6900 |
242 | $token = shift @$tokens or croak "missing ')'"; |
243 | $token eq ')' or croak "unexpected token : $token"; |
244 | $left = $left ? [CONCAT => [$left, [PAREN => $right]]] |
245 | : [PAREN => $right]; |
246 | } |
247 | # AND/OR |
248 | elsif ($token eq 'AND' || $token eq 'OR') { |
25823711 |
249 | my $right = _recurse_parse($tokens, PARSE_IN_EXPR); |
fffe6900 |
250 | $left = [$token => [$left, $right]]; |
251 | } |
25823711 |
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]]]; |
257 | } |
fffe6900 |
258 | # leaf expression |
259 | else { |
260 | $left = $left ? [CONCAT => [$left, [EXPR => $token]]] |
261 | : [EXPR => $token]; |
262 | } |
263 | } |
264 | } |
265 | |
266 | |
267 | |
268 | sub unparse { |
269 | my $tree = shift; |
270 | my $dispatch = { |
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]}}, |
276 | }; |
277 | $dispatch->{$tree->[0]}->(); |
278 | } |
279 | |
280 | |
281 | 1; |
282 | |
283 | |
284 | __END__ |
285 | |
286 | =head1 NAME |
287 | |
288 | SQL::Abstract::Test - Helper function for testing SQL::Abstract |
289 | |
290 | =head1 SYNOPSIS |
291 | |
292 | use SQL::Abstract; |
293 | use Test::More; |
e7827ba2 |
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 |
297 | /]; |
fffe6900 |
298 | |
299 | my ($sql, @bind) = SQL::Abstract->new->select(%args); |
e7827ba2 |
300 | |
fffe6900 |
301 | is_same_sql_bind($given_sql, \@given_bind, |
302 | $expected_sql, \@expected_bind, $test_msg); |
303 | |
e7827ba2 |
304 | is_same_sql($given_sql, $expected_sql, $test_msg); |
305 | is_same_bind(\@given_bind, \@expected_bind, $test_msg); |
306 | |
307 | my $is_same = eq_sql_bind($given_sql, \@given_bind, |
308 | $expected_sql, \@expected_bind); |
309 | |
310 | my $sql_same = eq_sql($given_sql, $expected_sql); |
311 | my $bind_same = eq_bind(\@given_bind, \@expected_bind); |
312 | |
fffe6900 |
313 | =head1 DESCRIPTION |
314 | |
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. |
319 | |
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. |
324 | |
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 |
328 | laws, etc. |
329 | |
330 | =head1 FUNCTIONS |
331 | |
332 | =head2 is_same_sql_bind |
333 | |
334 | is_same_sql_bind($given_sql, \@given_bind, |
335 | $expected_sql, \@expected_bind, $test_msg); |
336 | |
337 | Compares given and expected pairs of C<($sql, \@bind)>, and calls |
e7827ba2 |
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. |
342 | |
343 | =head2 is_same_sql |
344 | |
345 | is_same_sql($given_sql, $expected_sql, $test_msg); |
346 | |
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. |
352 | |
353 | =head2 is_same_bind |
354 | |
355 | is_same_bind(\@given_bind, \@expected_bind, $test_msg); |
356 | |
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 |
361 | to be imported. |
362 | |
363 | =head2 eq_sql_bind |
364 | |
365 | my $is_same = eq_sql_bind($given_sql, \@given_bind, |
366 | $expected_sql, \@expected_bind); |
367 | |
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>. |
fffe6900 |
371 | |
372 | =head2 eq_sql |
373 | |
374 | my $is_same = eq_sql($given_sql, $expected_sql); |
375 | |
e7827ba2 |
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. |
fffe6900 |
381 | |
382 | =head2 eq_bind |
383 | |
384 | my $is_same = eq_sql(\@given_bind, \@expected_bind); |
385 | |
e7827ba2 |
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>. |
fffe6900 |
390 | |
391 | =head1 GLOBAL VARIABLES |
392 | |
e7827ba2 |
393 | =head2 $case_sensitive |
fffe6900 |
394 | |
395 | If true, SQL comparisons will be case-sensitive. Default is false; |
396 | |
e7827ba2 |
397 | =head2 $sql_differ |
fffe6900 |
398 | |
399 | When L</eq_sql> returns false, the global variable |
400 | C<$sql_differ> contains the SQL portion |
401 | where a difference was encountered. |
402 | |
403 | |
404 | =head1 SEE ALSO |
405 | |
a6daa642 |
406 | L<SQL::Abstract>, L<Test::More>, L<Test::Builder>. |
fffe6900 |
407 | |
25823711 |
408 | =head1 AUTHORS |
fffe6900 |
409 | |
410 | Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt> |
411 | |
25823711 |
412 | Norbert Buchmuller <norbi@nix.hu> |
413 | |
fffe6900 |
414 | =head1 COPYRIGHT AND LICENSE |
415 | |
416 | Copyright 2008 by Laurent Dami. |
417 | |
418 | This library is free software; you can redistribute it and/or modify |
419 | it under the same terms as Perl itself. |