Commit | Line | Data |
fffe6900 |
1 | package SQL::Abstract::Test; # see doc at end of file |
2 | |
3 | use strict; |
4 | use warnings; |
ba3f5e40 |
5 | use base qw(Test::Builder::Module); |
4abea32b |
6 | use Test::Builder; |
328c5eac |
7 | use Test::Deep (); |
01dd4e4f |
8 | use SQL::Abstract::Tree; |
fffe6900 |
9 | |
c7e9c808 |
10 | { |
11 | my $class; |
12 | if ($class = $ENV{SQL_ABSTRACT_TEST_AGAINST}) { |
13 | my $mod = join('/', split '::', $class).".pm"; |
14 | require $mod; |
15 | eval qq{sub SQL::Abstract () { "\Q${class}\E" }; 1} |
16 | or die "Failed to create const sub for ${class}: $@"; |
17 | } |
18 | if ($ENV{SQL_ABSTRACT_TEST_EXPAND_STABILITY}) { |
19 | $class ||= do { require SQL::Abstract; 'SQL::Abstract' }; |
20 | my $orig = $class->can('expand_expr'); |
21 | require Data::Dumper::Concise; |
22 | my $wrapped = sub { |
23 | my ($self, @args) = @_; |
24 | my $e1 = $self->$orig(@args); |
656b11c3 |
25 | return $e1 if our $Stab_Check_Rec; |
26 | local $Stab_Check_Rec = 1; |
c7e9c808 |
27 | my $e2 = $self->$orig($e1); |
656b11c3 |
28 | my ($d1, $d2) = map Data::Dumper::Concise::Dumper($_), $e1, $e2; |
c7e9c808 |
29 | (our $tb)->is_eq( |
656b11c3 |
30 | $d2, $d1, |
c7e9c808 |
31 | 'expand_expr stability ok' |
656b11c3 |
32 | ) or do { |
33 | require Path::Tiny; |
34 | Path::Tiny->new('e1')->spew($d1); |
35 | Path::Tiny->new('e2')->spew($d2); |
e158ec37 |
36 | system('diff -u e1 e2 1>&2'); |
37 | die "Differences between e1 and e2, bailing out"; |
656b11c3 |
38 | }; |
c7e9c808 |
39 | return $e1; |
40 | }; |
41 | no strict 'refs'; no warnings 'redefine'; |
42 | *{"${class}::expand_expr"} = $wrapped; |
43 | } |
c9383a7b |
44 | } |
45 | |
2fadf08e |
46 | our @EXPORT_OK = qw( |
47 | is_same_sql_bind is_same_sql is_same_bind |
48 | eq_sql_bind eq_sql eq_bind dumper diag_where |
49 | $case_sensitive $sql_differ |
50 | ); |
fffe6900 |
51 | |
a24cc3a0 |
52 | my $sqlat = SQL::Abstract::Tree->new; |
53 | |
fffe6900 |
54 | our $case_sensitive = 0; |
e40f5df9 |
55 | our $parenthesis_significant = 0; |
0c2de280 |
56 | our $order_by_asc_significant = 0; |
57 | |
fffe6900 |
58 | our $sql_differ; # keeps track of differing portion between SQLs |
70af236b |
59 | our $tb; # not documented, but someone might be overriding it anyway |
fffe6900 |
60 | |
70c6f0e9 |
61 | sub _unpack_arrayrefref { |
62 | |
63 | my @args; |
64 | for (1,2) { |
65 | my $chunk = shift @_; |
66 | |
ca4f826a |
67 | if (ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY') { |
70c6f0e9 |
68 | my ($sql, @bind) = @$$chunk; |
69 | push @args, ($sql, \@bind); |
70 | } |
71 | else { |
72 | push @args, $chunk, shift @_; |
73 | } |
74 | |
75 | } |
76 | |
77 | # maybe $msg and ... stuff |
78 | push @args, @_; |
79 | |
80 | @args; |
81 | } |
82 | |
fffe6900 |
83 | sub is_same_sql_bind { |
70c6f0e9 |
84 | my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref; |
fffe6900 |
85 | |
86 | # compare |
25823711 |
87 | my $same_sql = eq_sql($sql1, $sql2); |
fffe6900 |
88 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
89 | |
a6daa642 |
90 | # call Test::Builder::ok |
70af236b |
91 | my $tb = $tb || __PACKAGE__->builder; |
1a828f61 |
92 | my $ret = $tb->ok($same_sql && $same_bind, $msg); |
fffe6900 |
93 | |
94 | # add debugging info |
95 | if (!$same_sql) { |
e7827ba2 |
96 | _sql_differ_diag($sql1, $sql2); |
fffe6900 |
97 | } |
98 | if (!$same_bind) { |
e7827ba2 |
99 | _bind_differ_diag($bind_ref1, $bind_ref2); |
fffe6900 |
100 | } |
1a828f61 |
101 | |
102 | # pass ok() result further |
103 | return $ret; |
fffe6900 |
104 | } |
105 | |
e7827ba2 |
106 | sub is_same_sql { |
107 | my ($sql1, $sql2, $msg) = @_; |
108 | |
109 | # compare |
70c6f0e9 |
110 | my $same_sql = eq_sql($sql1, $sql2); |
e7827ba2 |
111 | |
112 | # call Test::Builder::ok |
70af236b |
113 | my $tb = $tb || __PACKAGE__->builder; |
1a828f61 |
114 | my $ret = $tb->ok($same_sql, $msg); |
e7827ba2 |
115 | |
116 | # add debugging info |
117 | if (!$same_sql) { |
118 | _sql_differ_diag($sql1, $sql2); |
119 | } |
1a828f61 |
120 | |
121 | # pass ok() result further |
122 | return $ret; |
e7827ba2 |
123 | } |
124 | |
125 | sub is_same_bind { |
126 | my ($bind_ref1, $bind_ref2, $msg) = @_; |
127 | |
128 | # compare |
129 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
130 | |
131 | # call Test::Builder::ok |
70af236b |
132 | my $tb = $tb || __PACKAGE__->builder; |
1a828f61 |
133 | my $ret = $tb->ok($same_bind, $msg); |
e7827ba2 |
134 | |
135 | # add debugging info |
136 | if (!$same_bind) { |
137 | _bind_differ_diag($bind_ref1, $bind_ref2); |
138 | } |
1a828f61 |
139 | |
140 | # pass ok() result further |
141 | return $ret; |
e7827ba2 |
142 | } |
143 | |
2fadf08e |
144 | sub dumper { |
70c6f0e9 |
145 | # FIXME |
146 | # if we save the instance, we will end up with $VARx references |
147 | # no time to figure out how to avoid this (Deepcopy is *not* an option) |
148 | require Data::Dumper; |
149 | Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0) |
150 | ->Values([@_])->Dump; |
2fadf08e |
151 | } |
152 | |
153 | sub diag_where{ |
70af236b |
154 | my $tb = $tb || __PACKAGE__->builder; |
ca4f826a |
155 | $tb->diag("Search term:\n" . &dumper); |
2fadf08e |
156 | } |
157 | |
e7827ba2 |
158 | sub _sql_differ_diag { |
70c6f0e9 |
159 | my $sql1 = shift || ''; |
160 | my $sql2 = shift || ''; |
e7827ba2 |
161 | |
70af236b |
162 | my $tb = $tb || __PACKAGE__->builder; |
9a9b40f8 |
163 | |
164 | if (my $profile = $ENV{SQL_ABSTRACT_TEST_TREE_PROFILE}) { |
165 | my $sqlat = SQL::Abstract::Tree->new(profile => $profile); |
166 | $_ = $sqlat->format($_) for ($sql1, $sql2); |
167 | } |
168 | |
ca4f826a |
169 | $tb->${\($tb->in_todo ? 'note' : 'diag')} ( |
b3437526 |
170 | "SQL expressions differ\n" |
70c6f0e9 |
171 | ." got: $sql1\n" |
172 | ."want: $sql2\n" |
173 | ."\nmismatch around\n$sql_differ\n" |
b3437526 |
174 | ); |
e7827ba2 |
175 | } |
176 | |
177 | sub _bind_differ_diag { |
178 | my ($bind_ref1, $bind_ref2) = @_; |
179 | |
e026e02a |
180 | my $tb = $tb || __PACKAGE__->builder; |
ca4f826a |
181 | $tb->${\($tb->in_todo ? 'note' : 'diag')} ( |
70c6f0e9 |
182 | "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 }) |
183 | ); |
e7827ba2 |
184 | } |
185 | |
186 | sub eq_sql_bind { |
70c6f0e9 |
187 | my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref; |
e7827ba2 |
188 | |
189 | return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); |
190 | } |
191 | |
192 | |
328c5eac |
193 | sub eq_bind { goto &Test::Deep::eq_deeply }; |
fffe6900 |
194 | |
195 | sub eq_sql { |
25823711 |
196 | my ($sql1, $sql2) = @_; |
197 | |
198 | # parse |
a24cc3a0 |
199 | my $tree1 = $sqlat->parse($sql1); |
200 | my $tree2 = $sqlat->parse($sql2); |
25823711 |
201 | |
6f2a5b66 |
202 | undef $sql_differ; |
1b17d1b0 |
203 | return 1 if _eq_sql($tree1, $tree2); |
25823711 |
204 | } |
205 | |
206 | sub _eq_sql { |
fffe6900 |
207 | my ($left, $right) = @_; |
208 | |
939db550 |
209 | # one is defined the other not |
ca4f826a |
210 | if ((defined $left) xor (defined $right)) { |
211 | $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse($_) : 'N/A' } ($left, $right) ); |
939db550 |
212 | return 0; |
213 | } |
6f2a5b66 |
214 | |
939db550 |
215 | # one is undefined, then so is the other |
216 | elsif (not defined $left) { |
d15c14cc |
217 | return 1; |
218 | } |
6f2a5b66 |
219 | |
220 | # both are empty |
221 | elsif (@$left == 0 and @$right == 0) { |
0769ac0e |
222 | return 1; |
223 | } |
6f2a5b66 |
224 | |
225 | # one is empty |
226 | if (@$left == 0 or @$right == 0) { |
ca4f826a |
227 | $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse($_) : 'N/A'} ($left, $right) ); |
6f2a5b66 |
228 | return 0; |
229 | } |
230 | |
1b17d1b0 |
231 | # one is a list, the other is an op with a list |
232 | elsif (ref $left->[0] xor ref $right->[0]) { |
6f2a5b66 |
233 | $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map |
ca4f826a |
234 | { ref $_ ? $sqlat->unparse($_) : $_ } |
6f2a5b66 |
235 | ($left->[0], $right->[0], $left, $right) |
236 | ); |
fffe6900 |
237 | return 0; |
238 | } |
6f2a5b66 |
239 | |
240 | # both are lists |
1b17d1b0 |
241 | elsif (ref $left->[0]) { |
242 | for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) { |
6f2a5b66 |
243 | if (not _eq_sql ($left->[$i], $right->[$i]) ) { |
244 | if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) { |
245 | $sql_differ ||= ''; |
246 | $sql_differ .= "\n" unless $sql_differ =~ /\n\z/; |
ca4f826a |
247 | $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ); |
6f2a5b66 |
248 | } |
249 | return 0; |
250 | } |
1b17d1b0 |
251 | } |
252 | return 1; |
253 | } |
6f2a5b66 |
254 | |
255 | # both are ops |
1b17d1b0 |
256 | else { |
257 | |
e40f5df9 |
258 | # unroll parenthesis if possible/allowed |
ca4f826a |
259 | unless ($parenthesis_significant) { |
6f2a5b66 |
260 | $sqlat->_parenthesis_unroll($_) for $left, $right; |
261 | } |
1b17d1b0 |
262 | |
0c2de280 |
263 | # unroll ASC order by's |
264 | unless ($order_by_asc_significant) { |
265 | $sqlat->_strip_asc_from_order_by($_) for $left, $right; |
266 | } |
267 | |
ca4f826a |
268 | if ($left->[0] ne $right->[0]) { |
1b17d1b0 |
269 | $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", |
a24cc3a0 |
270 | $sqlat->unparse($left), |
6f2a5b66 |
271 | $sqlat->unparse($right) |
272 | ; |
1b17d1b0 |
273 | return 0; |
274 | } |
6f2a5b66 |
275 | |
276 | # literals have a different arg-sig |
277 | elsif ($left->[0] eq '-LITERAL') { |
278 | (my $l = " $left->[1][0] " ) =~ s/\s+/ /g; |
279 | (my $r = " $right->[1][0] ") =~ s/\s+/ /g; |
280 | my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r); |
281 | $sql_differ = "[$l] != [$r]\n" if not $eq; |
282 | return $eq; |
283 | } |
284 | |
285 | # if operators are identical, compare operands |
01dd4e4f |
286 | else { |
6f2a5b66 |
287 | my $eq = _eq_sql($left->[1], $right->[1]); |
ca4f826a |
288 | $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse($_) } ($left, $right) ) if not $eq; |
6f2a5b66 |
289 | return $eq; |
fffe6900 |
290 | } |
291 | } |
292 | } |
293 | |
7853a177 |
294 | sub parse { $sqlat->parse(@_) } |
fffe6900 |
295 | 1; |
296 | |
297 | |
298 | __END__ |
299 | |
300 | =head1 NAME |
301 | |
302 | SQL::Abstract::Test - Helper function for testing SQL::Abstract |
303 | |
304 | =head1 SYNOPSIS |
305 | |
306 | use SQL::Abstract; |
307 | use Test::More; |
e7827ba2 |
308 | use SQL::Abstract::Test import => [qw/ |
309 | is_same_sql_bind is_same_sql is_same_bind |
310 | eq_sql_bind eq_sql eq_bind |
311 | /]; |
ec9af79e |
312 | |
fffe6900 |
313 | my ($sql, @bind) = SQL::Abstract->new->select(%args); |
e7827ba2 |
314 | |
01dd4e4f |
315 | is_same_sql_bind($given_sql, \@given_bind, |
fffe6900 |
316 | $expected_sql, \@expected_bind, $test_msg); |
317 | |
e7827ba2 |
318 | is_same_sql($given_sql, $expected_sql, $test_msg); |
319 | is_same_bind(\@given_bind, \@expected_bind, $test_msg); |
320 | |
01dd4e4f |
321 | my $is_same = eq_sql_bind($given_sql, \@given_bind, |
e7827ba2 |
322 | $expected_sql, \@expected_bind); |
323 | |
324 | my $sql_same = eq_sql($given_sql, $expected_sql); |
325 | my $bind_same = eq_bind(\@given_bind, \@expected_bind); |
326 | |
fffe6900 |
327 | =head1 DESCRIPTION |
328 | |
329 | This module is only intended for authors of tests on |
330 | L<SQL::Abstract|SQL::Abstract> and related modules; |
331 | it exports functions for comparing two SQL statements |
332 | and their bound values. |
333 | |
334 | The SQL comparison is performed on I<abstract syntax>, |
335 | ignoring differences in spaces or in levels of parentheses. |
336 | Therefore the tests will pass as long as the semantics |
337 | is preserved, even if the surface syntax has changed. |
338 | |
ec9af79e |
339 | B<Disclaimer> : the semantic equivalence handling is pretty limited. |
340 | A lot of effort goes into distinguishing significant from |
341 | non-significant parenthesis, including AND/OR operator associativity. |
342 | Currently this module does not support commutativity and more |
70c6f0e9 |
343 | intelligent transformations like L<De Morgan's laws |
344 | |http://en.wikipedia.org/wiki/De_Morgan's_laws>, etc. |
ec9af79e |
345 | |
70c6f0e9 |
346 | For a good overview of what this test framework is currently capable of refer |
ec9af79e |
347 | to C<t/10test.t> |
fffe6900 |
348 | |
349 | =head1 FUNCTIONS |
350 | |
351 | =head2 is_same_sql_bind |
352 | |
70c6f0e9 |
353 | is_same_sql_bind( |
354 | $given_sql, \@given_bind, |
355 | $expected_sql, \@expected_bind, |
356 | $test_msg |
357 | ); |
fffe6900 |
358 | |
70c6f0e9 |
359 | is_same_sql_bind( |
360 | \[$given_sql, @given_bind], |
361 | \[$expected_sql, @expected_bind], |
362 | $test_msg |
363 | ); |
364 | |
365 | is_same_sql_bind( |
366 | $dbic_rs->as_query |
367 | $expected_sql, \@expected_bind, |
368 | $test_msg |
369 | ); |
370 | |
371 | Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_> |
372 | as shown in the examples above and passing the arguments to L</eq_sql> and |
373 | L</eq_bind>. Calls L<Test::Builder/ok> with the combined result, with |
374 | C<$test_msg> as message. |
375 | If the test fails, a detailed diagnostic is printed. |
e7827ba2 |
376 | |
377 | =head2 is_same_sql |
378 | |
70c6f0e9 |
379 | is_same_sql( |
380 | $given_sql, |
381 | $expected_sql, |
382 | $test_msg |
383 | ); |
e7827ba2 |
384 | |
70c6f0e9 |
385 | Compares given and expected SQL statements via L</eq_sql>, and calls |
386 | L<Test::Builder/ok> on the result, with C<$test_msg> as message. |
387 | If the test fails, a detailed diagnostic is printed. |
e7827ba2 |
388 | |
389 | =head2 is_same_bind |
390 | |
70c6f0e9 |
391 | is_same_bind( |
392 | \@given_bind, |
393 | \@expected_bind, |
394 | $test_msg |
395 | ); |
e7827ba2 |
396 | |
70c6f0e9 |
397 | Compares given and expected bind values via L</eq_bind>, and calls |
398 | L<Test::Builder/ok> on the result, with C<$test_msg> as message. |
399 | If the test fails, a detailed diagnostic is printed. |
e7827ba2 |
400 | |
401 | =head2 eq_sql_bind |
402 | |
70c6f0e9 |
403 | my $is_same = eq_sql_bind( |
404 | $given_sql, \@given_bind, |
405 | $expected_sql, \@expected_bind, |
406 | ); |
e7827ba2 |
407 | |
70c6f0e9 |
408 | my $is_same = eq_sql_bind( |
409 | \[$given_sql, @given_bind], |
410 | \[$expected_sql, @expected_bind], |
411 | ); |
412 | |
413 | my $is_same = eq_sql_bind( |
414 | $dbic_rs->as_query |
415 | $expected_sql, \@expected_bind, |
416 | ); |
417 | |
418 | Unpacks C<@_> depending on the given arguments and calls L</eq_sql> and |
419 | L</eq_bind>, returning their combined result. |
fffe6900 |
420 | |
421 | =head2 eq_sql |
422 | |
423 | my $is_same = eq_sql($given_sql, $expected_sql); |
424 | |
e7827ba2 |
425 | Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>, |
426 | but it just returns a boolean value and does not print diagnostics or talk to |
427 | L<Test::Builder>. If the result is false, the global variable L</$sql_differ> |
428 | will contain the SQL portion where a difference was encountered; this is useful |
429 | for printing diagnostics. |
fffe6900 |
430 | |
431 | =head2 eq_bind |
432 | |
433 | my $is_same = eq_sql(\@given_bind, \@expected_bind); |
434 | |
e7827ba2 |
435 | Compares two lists of bind values, taking into account the fact that some of |
436 | the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to |
437 | L</is_same_bind>, but it just returns a boolean value and does not print |
438 | diagnostics or talk to L<Test::Builder>. |
fffe6900 |
439 | |
440 | =head1 GLOBAL VARIABLES |
441 | |
e7827ba2 |
442 | =head2 $case_sensitive |
fffe6900 |
443 | |
444 | If true, SQL comparisons will be case-sensitive. Default is false; |
445 | |
e40f5df9 |
446 | =head2 $parenthesis_significant |
447 | |
448 | If true, SQL comparison will preserve and report difference in nested |
48d9f5f8 |
449 | parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>. |
450 | Defaults to false; |
e40f5df9 |
451 | |
0c2de280 |
452 | =head2 $order_by_asc_significant |
453 | |
454 | If true SQL comparison will consider C<ORDER BY foo ASC> and |
455 | C<ORDER BY foo> to be different. Default is false; |
456 | |
e7827ba2 |
457 | =head2 $sql_differ |
fffe6900 |
458 | |
459 | When L</eq_sql> returns false, the global variable |
460 | C<$sql_differ> contains the SQL portion |
461 | where a difference was encountered. |
462 | |
fffe6900 |
463 | =head1 SEE ALSO |
464 | |
a6daa642 |
465 | L<SQL::Abstract>, L<Test::More>, L<Test::Builder>. |
fffe6900 |
466 | |
25823711 |
467 | =head1 AUTHORS |
fffe6900 |
468 | |
70c6f0e9 |
469 | Laurent Dami <laurent.dami AT etat geneve ch> |
fffe6900 |
470 | |
25823711 |
471 | Norbert Buchmuller <norbi@nix.hu> |
472 | |
e96c510a |
473 | Peter Rabbitson <ribasushi@cpan.org> |
474 | |
fffe6900 |
475 | =head1 COPYRIGHT AND LICENSE |
476 | |
477 | Copyright 2008 by Laurent Dami. |
478 | |
479 | This library is free software; you can redistribute it and/or modify |
01dd4e4f |
480 | it under the same terms as Perl itself. |