Commit | Line | Data |
fffe6900 |
1 | package SQL::Abstract::Test; # see doc at end of file |
2 | |
3 | use strict; |
4 | use warnings; |
2fadf08e |
5 | use base qw(Test::Builder::Module Exporter); |
fffe6900 |
6 | use Data::Dumper; |
4abea32b |
7 | use Test::Builder; |
328c5eac |
8 | use Test::Deep (); |
01dd4e4f |
9 | use SQL::Abstract::Tree; |
fffe6900 |
10 | |
2fadf08e |
11 | our @EXPORT_OK = qw( |
12 | is_same_sql_bind is_same_sql is_same_bind |
13 | eq_sql_bind eq_sql eq_bind dumper diag_where |
14 | $case_sensitive $sql_differ |
15 | ); |
fffe6900 |
16 | |
a24cc3a0 |
17 | my $sqlat = SQL::Abstract::Tree->new; |
18 | |
fffe6900 |
19 | our $case_sensitive = 0; |
e40f5df9 |
20 | our $parenthesis_significant = 0; |
0c2de280 |
21 | our $order_by_asc_significant = 0; |
22 | |
fffe6900 |
23 | our $sql_differ; # keeps track of differing portion between SQLs |
5aad8cf3 |
24 | our $tb = __PACKAGE__->builder; |
fffe6900 |
25 | |
26 | sub is_same_sql_bind { |
27 | my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; |
28 | |
29 | # compare |
25823711 |
30 | my $same_sql = eq_sql($sql1, $sql2); |
fffe6900 |
31 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
32 | |
a6daa642 |
33 | # call Test::Builder::ok |
1a828f61 |
34 | my $ret = $tb->ok($same_sql && $same_bind, $msg); |
fffe6900 |
35 | |
36 | # add debugging info |
37 | if (!$same_sql) { |
e7827ba2 |
38 | _sql_differ_diag($sql1, $sql2); |
fffe6900 |
39 | } |
40 | if (!$same_bind) { |
e7827ba2 |
41 | _bind_differ_diag($bind_ref1, $bind_ref2); |
fffe6900 |
42 | } |
1a828f61 |
43 | |
44 | # pass ok() result further |
45 | return $ret; |
fffe6900 |
46 | } |
47 | |
e7827ba2 |
48 | sub is_same_sql { |
49 | my ($sql1, $sql2, $msg) = @_; |
50 | |
51 | # compare |
52 | my $same_sql = eq_sql($sql1, $sql2); |
53 | |
54 | # call Test::Builder::ok |
1a828f61 |
55 | my $ret = $tb->ok($same_sql, $msg); |
e7827ba2 |
56 | |
57 | # add debugging info |
58 | if (!$same_sql) { |
59 | _sql_differ_diag($sql1, $sql2); |
60 | } |
1a828f61 |
61 | |
62 | # pass ok() result further |
63 | return $ret; |
e7827ba2 |
64 | } |
65 | |
66 | sub is_same_bind { |
67 | my ($bind_ref1, $bind_ref2, $msg) = @_; |
68 | |
69 | # compare |
70 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
71 | |
72 | # call Test::Builder::ok |
1a828f61 |
73 | my $ret = $tb->ok($same_bind, $msg); |
e7827ba2 |
74 | |
75 | # add debugging info |
76 | if (!$same_bind) { |
77 | _bind_differ_diag($bind_ref1, $bind_ref2); |
78 | } |
1a828f61 |
79 | |
80 | # pass ok() result further |
81 | return $ret; |
e7827ba2 |
82 | } |
83 | |
2fadf08e |
84 | sub dumper { |
85 | Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0)->Values([@_])->Dump; |
86 | } |
87 | |
88 | sub diag_where{ |
89 | $tb->diag( "Search term:\n" . &dumper ); |
90 | } |
91 | |
e7827ba2 |
92 | sub _sql_differ_diag { |
93 | my ($sql1, $sql2) = @_; |
94 | |
b3437526 |
95 | $tb->${\( $tb->in_todo ? 'note' : 'diag')} ( |
96 | "SQL expressions differ\n" |
e7827ba2 |
97 | ." got: $sql1\n" |
98 | ."expected: $sql2\n" |
99 | ."differing in :\n$sql_differ\n" |
b3437526 |
100 | ); |
e7827ba2 |
101 | } |
102 | |
103 | sub _bind_differ_diag { |
104 | my ($bind_ref1, $bind_ref2) = @_; |
105 | |
b3437526 |
106 | $tb->${\( $tb->in_todo ? 'note' : 'diag')} ( |
107 | "BIND values differ\n" |
2fadf08e |
108 | ." got: " . dumper($bind_ref1) |
109 | ."expected: " . dumper($bind_ref2) |
e7827ba2 |
110 | ); |
111 | } |
112 | |
113 | sub eq_sql_bind { |
114 | my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_; |
115 | |
116 | return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); |
117 | } |
118 | |
119 | |
328c5eac |
120 | sub eq_bind { goto &Test::Deep::eq_deeply }; |
fffe6900 |
121 | |
122 | sub eq_sql { |
25823711 |
123 | my ($sql1, $sql2) = @_; |
124 | |
125 | # parse |
a24cc3a0 |
126 | my $tree1 = $sqlat->parse($sql1); |
127 | my $tree2 = $sqlat->parse($sql2); |
25823711 |
128 | |
6f2a5b66 |
129 | undef $sql_differ; |
1b17d1b0 |
130 | return 1 if _eq_sql($tree1, $tree2); |
25823711 |
131 | } |
132 | |
133 | sub _eq_sql { |
fffe6900 |
134 | my ($left, $right) = @_; |
135 | |
939db550 |
136 | # one is defined the other not |
137 | if ( (defined $left) xor (defined $right) ) { |
6f2a5b66 |
138 | $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) ); |
939db550 |
139 | return 0; |
140 | } |
6f2a5b66 |
141 | |
939db550 |
142 | # one is undefined, then so is the other |
143 | elsif (not defined $left) { |
d15c14cc |
144 | return 1; |
145 | } |
6f2a5b66 |
146 | |
147 | # both are empty |
148 | elsif (@$left == 0 and @$right == 0) { |
0769ac0e |
149 | return 1; |
150 | } |
6f2a5b66 |
151 | |
152 | # one is empty |
153 | if (@$left == 0 or @$right == 0) { |
154 | $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) ); |
155 | return 0; |
156 | } |
157 | |
1b17d1b0 |
158 | # one is a list, the other is an op with a list |
159 | elsif (ref $left->[0] xor ref $right->[0]) { |
6f2a5b66 |
160 | $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map |
161 | { ref $_ ? $sqlat->unparse ($_) : $_ } |
162 | ($left->[0], $right->[0], $left, $right) |
163 | ); |
fffe6900 |
164 | return 0; |
165 | } |
6f2a5b66 |
166 | |
167 | # both are lists |
1b17d1b0 |
168 | elsif (ref $left->[0]) { |
169 | for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) { |
6f2a5b66 |
170 | if (not _eq_sql ($left->[$i], $right->[$i]) ) { |
171 | if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) { |
172 | $sql_differ ||= ''; |
173 | $sql_differ .= "\n" unless $sql_differ =~ /\n\z/; |
174 | $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ); |
175 | } |
176 | return 0; |
177 | } |
1b17d1b0 |
178 | } |
179 | return 1; |
180 | } |
6f2a5b66 |
181 | |
182 | # both are ops |
1b17d1b0 |
183 | else { |
184 | |
e40f5df9 |
185 | # unroll parenthesis if possible/allowed |
6f2a5b66 |
186 | unless ( $parenthesis_significant ) { |
187 | $sqlat->_parenthesis_unroll($_) for $left, $right; |
188 | } |
1b17d1b0 |
189 | |
0c2de280 |
190 | # unroll ASC order by's |
191 | unless ($order_by_asc_significant) { |
192 | $sqlat->_strip_asc_from_order_by($_) for $left, $right; |
193 | } |
194 | |
b9a4fdae |
195 | if ( $left->[0] ne $right->[0] ) { |
1b17d1b0 |
196 | $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", |
a24cc3a0 |
197 | $sqlat->unparse($left), |
6f2a5b66 |
198 | $sqlat->unparse($right) |
199 | ; |
1b17d1b0 |
200 | return 0; |
201 | } |
6f2a5b66 |
202 | |
203 | # literals have a different arg-sig |
204 | elsif ($left->[0] eq '-LITERAL') { |
205 | (my $l = " $left->[1][0] " ) =~ s/\s+/ /g; |
206 | (my $r = " $right->[1][0] ") =~ s/\s+/ /g; |
207 | my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r); |
208 | $sql_differ = "[$l] != [$r]\n" if not $eq; |
209 | return $eq; |
210 | } |
211 | |
212 | # if operators are identical, compare operands |
01dd4e4f |
213 | else { |
6f2a5b66 |
214 | my $eq = _eq_sql($left->[1], $right->[1]); |
215 | $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq; |
216 | return $eq; |
fffe6900 |
217 | } |
218 | } |
219 | } |
220 | |
7853a177 |
221 | sub parse { $sqlat->parse(@_) } |
fffe6900 |
222 | 1; |
223 | |
224 | |
225 | __END__ |
226 | |
227 | =head1 NAME |
228 | |
229 | SQL::Abstract::Test - Helper function for testing SQL::Abstract |
230 | |
231 | =head1 SYNOPSIS |
232 | |
233 | use SQL::Abstract; |
234 | use Test::More; |
e7827ba2 |
235 | use SQL::Abstract::Test import => [qw/ |
236 | is_same_sql_bind is_same_sql is_same_bind |
237 | eq_sql_bind eq_sql eq_bind |
238 | /]; |
ec9af79e |
239 | |
fffe6900 |
240 | my ($sql, @bind) = SQL::Abstract->new->select(%args); |
e7827ba2 |
241 | |
01dd4e4f |
242 | is_same_sql_bind($given_sql, \@given_bind, |
fffe6900 |
243 | $expected_sql, \@expected_bind, $test_msg); |
244 | |
e7827ba2 |
245 | is_same_sql($given_sql, $expected_sql, $test_msg); |
246 | is_same_bind(\@given_bind, \@expected_bind, $test_msg); |
247 | |
01dd4e4f |
248 | my $is_same = eq_sql_bind($given_sql, \@given_bind, |
e7827ba2 |
249 | $expected_sql, \@expected_bind); |
250 | |
251 | my $sql_same = eq_sql($given_sql, $expected_sql); |
252 | my $bind_same = eq_bind(\@given_bind, \@expected_bind); |
253 | |
fffe6900 |
254 | =head1 DESCRIPTION |
255 | |
256 | This module is only intended for authors of tests on |
257 | L<SQL::Abstract|SQL::Abstract> and related modules; |
258 | it exports functions for comparing two SQL statements |
259 | and their bound values. |
260 | |
261 | The SQL comparison is performed on I<abstract syntax>, |
262 | ignoring differences in spaces or in levels of parentheses. |
263 | Therefore the tests will pass as long as the semantics |
264 | is preserved, even if the surface syntax has changed. |
265 | |
ec9af79e |
266 | B<Disclaimer> : the semantic equivalence handling is pretty limited. |
267 | A lot of effort goes into distinguishing significant from |
268 | non-significant parenthesis, including AND/OR operator associativity. |
269 | Currently this module does not support commutativity and more |
270 | intelligent transformations like Morgan laws, etc. |
271 | |
01dd4e4f |
272 | For a good overview of what this test framework is capable of refer |
ec9af79e |
273 | to C<t/10test.t> |
fffe6900 |
274 | |
275 | =head1 FUNCTIONS |
276 | |
277 | =head2 is_same_sql_bind |
278 | |
01dd4e4f |
279 | is_same_sql_bind($given_sql, \@given_bind, |
fffe6900 |
280 | $expected_sql, \@expected_bind, $test_msg); |
281 | |
282 | Compares given and expected pairs of C<($sql, \@bind)>, and calls |
e7827ba2 |
283 | L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test |
284 | fails, a detailed diagnostic is printed. For clients which use L<Test::More>, |
285 | this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>, |
286 | L</is_same_bind>) that needs to be imported. |
287 | |
288 | =head2 is_same_sql |
289 | |
290 | is_same_sql($given_sql, $expected_sql, $test_msg); |
291 | |
292 | Compares given and expected SQL statements, and calls L<Test::Builder/ok> on |
293 | the result, with C<$test_msg> as message. If the test fails, a detailed |
294 | diagnostic is printed. For clients which use L<Test::More>, this is the one of |
295 | the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) |
296 | that needs to be imported. |
297 | |
298 | =head2 is_same_bind |
299 | |
300 | is_same_bind(\@given_bind, \@expected_bind, $test_msg); |
301 | |
302 | Compares given and expected bind values, and calls L<Test::Builder/ok> on the |
303 | result, with C<$test_msg> as message. If the test fails, a detailed diagnostic |
304 | is printed. For clients which use L<Test::More>, this is the one of the three |
305 | functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs |
306 | to be imported. |
307 | |
308 | =head2 eq_sql_bind |
309 | |
01dd4e4f |
310 | my $is_same = eq_sql_bind($given_sql, \@given_bind, |
e7827ba2 |
311 | $expected_sql, \@expected_bind); |
312 | |
313 | Compares given and expected pairs of C<($sql, \@bind)>. Similar to |
314 | L</is_same_sql_bind>, but it just returns a boolean value and does not print |
315 | diagnostics or talk to L<Test::Builder>. |
fffe6900 |
316 | |
317 | =head2 eq_sql |
318 | |
319 | my $is_same = eq_sql($given_sql, $expected_sql); |
320 | |
e7827ba2 |
321 | Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>, |
322 | but it just returns a boolean value and does not print diagnostics or talk to |
323 | L<Test::Builder>. If the result is false, the global variable L</$sql_differ> |
324 | will contain the SQL portion where a difference was encountered; this is useful |
325 | for printing diagnostics. |
fffe6900 |
326 | |
327 | =head2 eq_bind |
328 | |
329 | my $is_same = eq_sql(\@given_bind, \@expected_bind); |
330 | |
e7827ba2 |
331 | Compares two lists of bind values, taking into account the fact that some of |
332 | the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to |
333 | L</is_same_bind>, but it just returns a boolean value and does not print |
334 | diagnostics or talk to L<Test::Builder>. |
fffe6900 |
335 | |
336 | =head1 GLOBAL VARIABLES |
337 | |
e7827ba2 |
338 | =head2 $case_sensitive |
fffe6900 |
339 | |
340 | If true, SQL comparisons will be case-sensitive. Default is false; |
341 | |
e40f5df9 |
342 | =head2 $parenthesis_significant |
343 | |
344 | If true, SQL comparison will preserve and report difference in nested |
48d9f5f8 |
345 | parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>. |
346 | Defaults to false; |
e40f5df9 |
347 | |
0c2de280 |
348 | =head2 $order_by_asc_significant |
349 | |
350 | If true SQL comparison will consider C<ORDER BY foo ASC> and |
351 | C<ORDER BY foo> to be different. Default is false; |
352 | |
e7827ba2 |
353 | =head2 $sql_differ |
fffe6900 |
354 | |
355 | When L</eq_sql> returns false, the global variable |
356 | C<$sql_differ> contains the SQL portion |
357 | where a difference was encountered. |
358 | |
359 | |
360 | =head1 SEE ALSO |
361 | |
a6daa642 |
362 | L<SQL::Abstract>, L<Test::More>, L<Test::Builder>. |
fffe6900 |
363 | |
25823711 |
364 | =head1 AUTHORS |
fffe6900 |
365 | |
366 | Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt> |
367 | |
25823711 |
368 | Norbert Buchmuller <norbi@nix.hu> |
369 | |
e96c510a |
370 | Peter Rabbitson <ribasushi@cpan.org> |
371 | |
fffe6900 |
372 | =head1 COPYRIGHT AND LICENSE |
373 | |
374 | Copyright 2008 by Laurent Dami. |
375 | |
376 | This library is free software; you can redistribute it and/or modify |
01dd4e4f |
377 | it under the same terms as Perl itself. |