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