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; |
4abea32b |
7 | use Test::Builder; |
01dd4e4f |
8 | use SQL::Abstract::Tree; |
fffe6900 |
9 | |
e7827ba2 |
10 | our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind |
01dd4e4f |
11 | &eq_sql_bind &eq_sql &eq_bind |
fffe6900 |
12 | $case_sensitive $sql_differ/; |
13 | |
a24cc3a0 |
14 | my $sqlat = SQL::Abstract::Tree->new; |
15 | |
fffe6900 |
16 | our $case_sensitive = 0; |
e40f5df9 |
17 | our $parenthesis_significant = 0; |
fffe6900 |
18 | our $sql_differ; # keeps track of differing portion between SQLs |
5aad8cf3 |
19 | our $tb = __PACKAGE__->builder; |
fffe6900 |
20 | |
35149895 |
21 | # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics |
01b64cb7 |
22 | my @unrollable_ops = ( |
1b17d1b0 |
23 | 'ON', |
24 | 'WHERE', |
25 | 'GROUP \s+ BY', |
26 | 'HAVING', |
27 | 'ORDER \s+ BY', |
28 | ); |
6f01d627 |
29 | my $unrollable_ops_re = join ' | ', @unrollable_ops; |
b7b0f832 |
30 | $unrollable_ops_re = qr/$unrollable_ops_re/xi; |
1b17d1b0 |
31 | |
fffe6900 |
32 | sub is_same_sql_bind { |
33 | my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; |
34 | |
35 | # compare |
25823711 |
36 | my $same_sql = eq_sql($sql1, $sql2); |
fffe6900 |
37 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
38 | |
a6daa642 |
39 | # call Test::Builder::ok |
1a828f61 |
40 | my $ret = $tb->ok($same_sql && $same_bind, $msg); |
fffe6900 |
41 | |
42 | # add debugging info |
43 | if (!$same_sql) { |
e7827ba2 |
44 | _sql_differ_diag($sql1, $sql2); |
fffe6900 |
45 | } |
46 | if (!$same_bind) { |
e7827ba2 |
47 | _bind_differ_diag($bind_ref1, $bind_ref2); |
fffe6900 |
48 | } |
1a828f61 |
49 | |
50 | # pass ok() result further |
51 | return $ret; |
fffe6900 |
52 | } |
53 | |
e7827ba2 |
54 | sub is_same_sql { |
55 | my ($sql1, $sql2, $msg) = @_; |
56 | |
57 | # compare |
58 | my $same_sql = eq_sql($sql1, $sql2); |
59 | |
60 | # call Test::Builder::ok |
1a828f61 |
61 | my $ret = $tb->ok($same_sql, $msg); |
e7827ba2 |
62 | |
63 | # add debugging info |
64 | if (!$same_sql) { |
65 | _sql_differ_diag($sql1, $sql2); |
66 | } |
1a828f61 |
67 | |
68 | # pass ok() result further |
69 | return $ret; |
e7827ba2 |
70 | } |
71 | |
72 | sub is_same_bind { |
73 | my ($bind_ref1, $bind_ref2, $msg) = @_; |
74 | |
75 | # compare |
76 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
77 | |
78 | # call Test::Builder::ok |
1a828f61 |
79 | my $ret = $tb->ok($same_bind, $msg); |
e7827ba2 |
80 | |
81 | # add debugging info |
82 | if (!$same_bind) { |
83 | _bind_differ_diag($bind_ref1, $bind_ref2); |
84 | } |
1a828f61 |
85 | |
86 | # pass ok() result further |
87 | return $ret; |
e7827ba2 |
88 | } |
89 | |
90 | sub _sql_differ_diag { |
91 | my ($sql1, $sql2) = @_; |
92 | |
93 | $tb->diag("SQL expressions differ\n" |
94 | ." got: $sql1\n" |
95 | ."expected: $sql2\n" |
96 | ."differing in :\n$sql_differ\n" |
97 | ); |
98 | } |
99 | |
100 | sub _bind_differ_diag { |
101 | my ($bind_ref1, $bind_ref2) = @_; |
102 | |
103 | $tb->diag("BIND values differ\n" |
104 | ." got: " . Dumper($bind_ref1) |
105 | ."expected: " . Dumper($bind_ref2) |
106 | ); |
107 | } |
108 | |
109 | sub eq_sql_bind { |
110 | my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_; |
111 | |
112 | return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); |
113 | } |
114 | |
115 | |
fffe6900 |
116 | sub eq_bind { |
117 | my ($bind_ref1, $bind_ref2) = @_; |
fffe6900 |
118 | |
fdfbbc65 |
119 | local $Data::Dumper::Useqq = 1; |
120 | local $Data::Dumper::Sortkeys = 1; |
121 | |
122 | return Dumper($bind_ref1) eq Dumper($bind_ref2); |
fffe6900 |
123 | } |
124 | |
125 | sub eq_sql { |
25823711 |
126 | my ($sql1, $sql2) = @_; |
127 | |
128 | # parse |
a24cc3a0 |
129 | my $tree1 = $sqlat->parse($sql1); |
130 | my $tree2 = $sqlat->parse($sql2); |
25823711 |
131 | |
1b17d1b0 |
132 | return 1 if _eq_sql($tree1, $tree2); |
25823711 |
133 | } |
134 | |
135 | sub _eq_sql { |
fffe6900 |
136 | my ($left, $right) = @_; |
137 | |
939db550 |
138 | # one is defined the other not |
139 | if ( (defined $left) xor (defined $right) ) { |
140 | return 0; |
141 | } |
142 | # one is undefined, then so is the other |
143 | elsif (not defined $left) { |
d15c14cc |
144 | return 1; |
145 | } |
0769ac0e |
146 | # different amount of elements |
147 | elsif (@$left != @$right) { |
148 | $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ); |
149 | return 0; |
150 | } |
151 | # one is empty - so is the other |
152 | elsif (@$left == 0) { |
153 | return 1; |
154 | } |
1b17d1b0 |
155 | # one is a list, the other is an op with a list |
156 | elsif (ref $left->[0] xor ref $right->[0]) { |
a24cc3a0 |
157 | $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ); |
fffe6900 |
158 | return 0; |
159 | } |
1b17d1b0 |
160 | # one is a list, so is the other |
161 | elsif (ref $left->[0]) { |
162 | for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) { |
163 | return 0 if (not _eq_sql ($left->[$i], $right->[$i]) ); |
164 | } |
165 | return 1; |
166 | } |
167 | # both are an op-list combo |
168 | else { |
169 | |
e40f5df9 |
170 | # unroll parenthesis if possible/allowed |
171 | _parenthesis_unroll ($_) for ($left, $right); |
1b17d1b0 |
172 | |
173 | # if operators are different |
b9a4fdae |
174 | if ( $left->[0] ne $right->[0] ) { |
1b17d1b0 |
175 | $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", |
a24cc3a0 |
176 | $sqlat->unparse($left), |
177 | $sqlat->unparse($right); |
1b17d1b0 |
178 | return 0; |
179 | } |
180 | # elsif operators are identical, compare operands |
01dd4e4f |
181 | else { |
b9a4fdae |
182 | if ($left->[0] eq 'LITERAL' ) { # unary |
01b64cb7 |
183 | (my $l = " $left->[1][0] " ) =~ s/\s+/ /g; |
184 | (my $r = " $right->[1][0] ") =~ s/\s+/ /g; |
1b17d1b0 |
185 | my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r); |
01b64cb7 |
186 | $sql_differ = "[$l] != [$r]\n" if not $eq; |
1b17d1b0 |
187 | return $eq; |
188 | } |
189 | else { |
190 | my $eq = _eq_sql($left->[1], $right->[1]); |
a24cc3a0 |
191 | $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq; |
1b17d1b0 |
192 | return $eq; |
193 | } |
fffe6900 |
194 | } |
195 | } |
196 | } |
197 | |
e40f5df9 |
198 | sub _parenthesis_unroll { |
199 | my $ast = shift; |
200 | |
201 | return if $parenthesis_significant; |
202 | return unless (ref $ast and ref $ast->[1]); |
203 | |
204 | my $changes; |
205 | do { |
206 | my @children; |
207 | $changes = 0; |
208 | |
209 | for my $child (@{$ast->[1]}) { |
0769ac0e |
210 | # the current node in this loop is *always* a PAREN |
e40f5df9 |
211 | if (not ref $child or not $child->[0] eq 'PAREN') { |
212 | push @children, $child; |
213 | next; |
214 | } |
215 | |
216 | # unroll nested parenthesis |
0769ac0e |
217 | while ( @{$child->[1]} && $child->[1][0][0] eq 'PAREN') { |
e40f5df9 |
218 | $child = $child->[1][0]; |
219 | $changes++; |
220 | } |
221 | |
222 | # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list |
223 | if ( |
224 | ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR') |
225 | and |
226 | $child->[1][0][0] eq $ast->[0] |
227 | ) { |
228 | push @children, @{$child->[1][0][1]}; |
229 | $changes++; |
230 | } |
fffe6900 |
231 | |
e40f5df9 |
232 | # if the parent operator explcitly allows it nuke the parenthesis |
6f01d627 |
233 | elsif ( $ast->[0] =~ $unrollable_ops_re ) { |
e40f5df9 |
234 | push @children, $child->[1][0]; |
235 | $changes++; |
236 | } |
237 | |
0769ac0e |
238 | # only *ONE* LITERAL element |
9e8dab3f |
239 | elsif ( |
b9a4fdae |
240 | @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL' |
9e8dab3f |
241 | ) { |
242 | push @children, $child->[1][0]; |
243 | $changes++; |
244 | } |
245 | |
0769ac0e |
246 | # only one element in the parenthesis which is a binary op |
247 | # and has exactly two grandchildren |
248 | # the only time when we can *not* unroll this is when both |
249 | # the parent and the child are mathops (in which case we'll |
250 | # break precedence) or when the child is BETWEEN (special |
251 | # case) |
e40f5df9 |
252 | elsif ( |
253 | @{$child->[1]} == 1 |
254 | and |
0769ac0e |
255 | $child->[1][0][0] =~ SQL::Abstract::Tree::_binary_op_re() |
e40f5df9 |
256 | and |
0769ac0e |
257 | $child->[1][0][0] ne 'BETWEEN' |
e40f5df9 |
258 | and |
0769ac0e |
259 | @{$child->[1][0][1]} == 2 |
260 | and |
261 | ! ( |
262 | $child->[1][0][0] =~ SQL::Abstract::Tree::_math_op_re() |
263 | and |
264 | $ast->[0] =~ SQL::Abstract::Tree::_math_op_re() |
265 | ) |
e40f5df9 |
266 | ) { |
267 | push @children, $child->[1][0]; |
268 | $changes++; |
269 | } |
270 | |
0769ac0e |
271 | # a function binds tighter than a mathop - see if our ancestor is a |
b3b79607 |
272 | # mathop, and our content is: |
273 | # a single non-mathop child with a single PAREN grandchild which |
274 | # would indicate mathop ( nonmathop ( ... ) ) |
275 | # or a single non-mathop with a single LITERAL ( nonmathop ? ) |
0769ac0e |
276 | elsif ( |
277 | @{$child->[1]} == 1 |
278 | and |
279 | @{$child->[1][0][1]} == 1 |
280 | and |
0769ac0e |
281 | $ast->[0] =~ SQL::Abstract::Tree::_math_op_re() |
282 | and |
283 | $child->[1][0][0] !~ SQL::Abstract::Tree::_math_op_re |
b3b79607 |
284 | and |
285 | ( |
286 | $child->[1][0][1][0][0] eq 'PAREN' |
287 | or |
288 | $child->[1][0][1][0][0] eq 'LITERAL' |
289 | ) |
0769ac0e |
290 | ) { |
291 | push @children, $child->[1][0]; |
292 | $changes++; |
293 | } |
294 | |
295 | |
e40f5df9 |
296 | # otherwise no more mucking for this pass |
297 | else { |
298 | push @children, $child; |
299 | } |
300 | } |
301 | |
302 | $ast->[1] = \@children; |
303 | |
304 | } while ($changes); |
305 | |
306 | } |
fffe6900 |
307 | |
7853a177 |
308 | sub parse { $sqlat->parse(@_) } |
fffe6900 |
309 | 1; |
310 | |
311 | |
312 | __END__ |
313 | |
314 | =head1 NAME |
315 | |
316 | SQL::Abstract::Test - Helper function for testing SQL::Abstract |
317 | |
318 | =head1 SYNOPSIS |
319 | |
320 | use SQL::Abstract; |
321 | use Test::More; |
e7827ba2 |
322 | use SQL::Abstract::Test import => [qw/ |
323 | is_same_sql_bind is_same_sql is_same_bind |
324 | eq_sql_bind eq_sql eq_bind |
325 | /]; |
ec9af79e |
326 | |
fffe6900 |
327 | my ($sql, @bind) = SQL::Abstract->new->select(%args); |
e7827ba2 |
328 | |
01dd4e4f |
329 | is_same_sql_bind($given_sql, \@given_bind, |
fffe6900 |
330 | $expected_sql, \@expected_bind, $test_msg); |
331 | |
e7827ba2 |
332 | is_same_sql($given_sql, $expected_sql, $test_msg); |
333 | is_same_bind(\@given_bind, \@expected_bind, $test_msg); |
334 | |
01dd4e4f |
335 | my $is_same = eq_sql_bind($given_sql, \@given_bind, |
e7827ba2 |
336 | $expected_sql, \@expected_bind); |
337 | |
338 | my $sql_same = eq_sql($given_sql, $expected_sql); |
339 | my $bind_same = eq_bind(\@given_bind, \@expected_bind); |
340 | |
fffe6900 |
341 | =head1 DESCRIPTION |
342 | |
343 | This module is only intended for authors of tests on |
344 | L<SQL::Abstract|SQL::Abstract> and related modules; |
345 | it exports functions for comparing two SQL statements |
346 | and their bound values. |
347 | |
348 | The SQL comparison is performed on I<abstract syntax>, |
349 | ignoring differences in spaces or in levels of parentheses. |
350 | Therefore the tests will pass as long as the semantics |
351 | is preserved, even if the surface syntax has changed. |
352 | |
ec9af79e |
353 | B<Disclaimer> : the semantic equivalence handling is pretty limited. |
354 | A lot of effort goes into distinguishing significant from |
355 | non-significant parenthesis, including AND/OR operator associativity. |
356 | Currently this module does not support commutativity and more |
357 | intelligent transformations like Morgan laws, etc. |
358 | |
01dd4e4f |
359 | For a good overview of what this test framework is capable of refer |
ec9af79e |
360 | to C<t/10test.t> |
fffe6900 |
361 | |
362 | =head1 FUNCTIONS |
363 | |
364 | =head2 is_same_sql_bind |
365 | |
01dd4e4f |
366 | is_same_sql_bind($given_sql, \@given_bind, |
fffe6900 |
367 | $expected_sql, \@expected_bind, $test_msg); |
368 | |
369 | Compares given and expected pairs of C<($sql, \@bind)>, and calls |
e7827ba2 |
370 | L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test |
371 | fails, a detailed diagnostic is printed. For clients which use L<Test::More>, |
372 | this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>, |
373 | L</is_same_bind>) that needs to be imported. |
374 | |
375 | =head2 is_same_sql |
376 | |
377 | is_same_sql($given_sql, $expected_sql, $test_msg); |
378 | |
379 | Compares given and expected SQL statements, and calls L<Test::Builder/ok> on |
380 | the result, with C<$test_msg> as message. If the test fails, a detailed |
381 | diagnostic is printed. For clients which use L<Test::More>, this is the one of |
382 | the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) |
383 | that needs to be imported. |
384 | |
385 | =head2 is_same_bind |
386 | |
387 | is_same_bind(\@given_bind, \@expected_bind, $test_msg); |
388 | |
389 | Compares given and expected bind values, and calls L<Test::Builder/ok> on the |
390 | result, with C<$test_msg> as message. If the test fails, a detailed diagnostic |
391 | is printed. For clients which use L<Test::More>, this is the one of the three |
392 | functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs |
393 | to be imported. |
394 | |
395 | =head2 eq_sql_bind |
396 | |
01dd4e4f |
397 | my $is_same = eq_sql_bind($given_sql, \@given_bind, |
e7827ba2 |
398 | $expected_sql, \@expected_bind); |
399 | |
400 | Compares given and expected pairs of C<($sql, \@bind)>. Similar to |
401 | L</is_same_sql_bind>, but it just returns a boolean value and does not print |
402 | diagnostics or talk to L<Test::Builder>. |
fffe6900 |
403 | |
404 | =head2 eq_sql |
405 | |
406 | my $is_same = eq_sql($given_sql, $expected_sql); |
407 | |
e7827ba2 |
408 | Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>, |
409 | but it just returns a boolean value and does not print diagnostics or talk to |
410 | L<Test::Builder>. If the result is false, the global variable L</$sql_differ> |
411 | will contain the SQL portion where a difference was encountered; this is useful |
412 | for printing diagnostics. |
fffe6900 |
413 | |
414 | =head2 eq_bind |
415 | |
416 | my $is_same = eq_sql(\@given_bind, \@expected_bind); |
417 | |
e7827ba2 |
418 | Compares two lists of bind values, taking into account the fact that some of |
419 | the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to |
420 | L</is_same_bind>, but it just returns a boolean value and does not print |
421 | diagnostics or talk to L<Test::Builder>. |
fffe6900 |
422 | |
423 | =head1 GLOBAL VARIABLES |
424 | |
e7827ba2 |
425 | =head2 $case_sensitive |
fffe6900 |
426 | |
427 | If true, SQL comparisons will be case-sensitive. Default is false; |
428 | |
e40f5df9 |
429 | =head2 $parenthesis_significant |
430 | |
431 | If true, SQL comparison will preserve and report difference in nested |
432 | parenthesis. Useful for testing the C<-nest> modifier. Defaults to false; |
433 | |
e7827ba2 |
434 | =head2 $sql_differ |
fffe6900 |
435 | |
436 | When L</eq_sql> returns false, the global variable |
437 | C<$sql_differ> contains the SQL portion |
438 | where a difference was encountered. |
439 | |
440 | |
441 | =head1 SEE ALSO |
442 | |
a6daa642 |
443 | L<SQL::Abstract>, L<Test::More>, L<Test::Builder>. |
fffe6900 |
444 | |
25823711 |
445 | =head1 AUTHORS |
fffe6900 |
446 | |
447 | Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt> |
448 | |
25823711 |
449 | Norbert Buchmuller <norbi@nix.hu> |
450 | |
e96c510a |
451 | Peter Rabbitson <ribasushi@cpan.org> |
452 | |
fffe6900 |
453 | =head1 COPYRIGHT AND LICENSE |
454 | |
455 | Copyright 2008 by Laurent Dami. |
456 | |
457 | This library is free software; you can redistribute it and/or modify |
01dd4e4f |
458 | it under the same terms as Perl itself. |