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/; |
32c34379 |
6 | use Scalar::Util qw(looks_like_number blessed reftype); |
fffe6900 |
7 | use Data::Dumper; |
8 | use Carp; |
9 | |
10 | our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind |
11 | $case_sensitive $sql_differ/; |
12 | |
13 | our $case_sensitive = 0; |
14 | our $sql_differ; # keeps track of differing portion between SQLs |
5aad8cf3 |
15 | our $tb = __PACKAGE__->builder; |
fffe6900 |
16 | |
17 | sub is_same_sql_bind { |
18 | my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; |
19 | |
20 | # compare |
21 | my $tree1 = parse($sql1); |
22 | my $tree2 = parse($sql2); |
23 | my $same_sql = eq_sql($tree1, $tree2); |
24 | my $same_bind = eq_bind($bind_ref1, $bind_ref2); |
25 | |
a6daa642 |
26 | # call Test::Builder::ok |
5aad8cf3 |
27 | $tb->ok($same_sql && $same_bind, $msg); |
fffe6900 |
28 | |
29 | # add debugging info |
30 | if (!$same_sql) { |
5aad8cf3 |
31 | $tb->diag("SQL expressions differ\n" |
fffe6900 |
32 | ." got: $sql1\n" |
33 | ."expected: $sql2\n" |
5aad8cf3 |
34 | ."differing in :\n$sql_differ\n" |
35 | ); |
fffe6900 |
36 | } |
37 | if (!$same_bind) { |
5aad8cf3 |
38 | $tb->diag("BIND values differ\n" |
fffe6900 |
39 | ." got: " . Dumper($bind_ref1) |
40 | ."expected: " . Dumper($bind_ref2) |
5aad8cf3 |
41 | ); |
fffe6900 |
42 | } |
43 | } |
44 | |
fffe6900 |
45 | sub eq_bind { |
46 | my ($bind_ref1, $bind_ref2) = @_; |
fffe6900 |
47 | |
32c34379 |
48 | my $ref1 = ref $bind_ref1; |
49 | my $ref2 = ref $bind_ref2; |
fffe6900 |
50 | |
32c34379 |
51 | return 0 if $ref1 ne $ref2; |
fffe6900 |
52 | |
32c34379 |
53 | if ($ref1 eq 'SCALAR' || $ref1 eq 'REF') { |
54 | return eq_bind($$bind_ref1, $$bind_ref2); |
55 | } elsif ($ref1 eq 'ARRAY') { |
56 | return 0 if scalar @$bind_ref1 != scalar @$bind_ref2; |
57 | for (my $i = 0; $i < @$bind_ref1; $i++) { |
58 | return 0 if !eq_bind($bind_ref1->[$i], $bind_ref2->[$i]); |
59 | } |
60 | return 1; |
61 | } elsif ($ref1 eq 'HASH') { |
62 | return |
63 | eq_bind( |
64 | [sort keys %$bind_ref1], |
65 | [sort keys %$bind_ref2] |
66 | ) |
67 | && eq_bind( |
68 | [map { $bind_ref1->{$_} } sort keys %$bind_ref1], |
69 | [map { $bind_ref2->{$_} } sort keys %$bind_ref2] |
70 | ); |
71 | } else { |
72 | if (!defined $bind_ref1 || !defined $bind_ref2) { |
73 | return !(defined $bind_ref1 ^ defined $bind_ref2); |
74 | } elsif (blessed($bind_ref1) || blessed($bind_ref2)) { |
75 | return 0 if (blessed($bind_ref1) || "") ne (blessed($bind_ref2) || ""); |
76 | return 1 if $bind_ref1 == $bind_ref2; # uses overloaded '==' |
77 | # fallback: compare the guts of the object |
78 | my $reftype1 = reftype $bind_ref1; |
79 | my $reftype2 = reftype $bind_ref2; |
80 | return 0 if $reftype1 ne $reftype2; |
81 | if ($reftype1 eq 'SCALAR' || $reftype1 eq 'REF') { |
82 | $bind_ref1 = $$bind_ref1; |
83 | $bind_ref2 = $$bind_ref2; |
84 | } elsif ($reftype1 eq 'ARRAY') { |
85 | $bind_ref1 = [@$bind_ref1]; |
86 | $bind_ref2 = [@$bind_ref2]; |
87 | } elsif ($reftype1 eq 'HASH') { |
88 | $bind_ref1 = {%$bind_ref1}; |
89 | $bind_ref2 = {%$bind_ref2}; |
90 | } else { |
91 | return 0; |
92 | } |
93 | return eq_bind($bind_ref1, $bind_ref2); |
94 | } elsif (looks_like_number($bind_ref1) && looks_like_number($bind_ref2)) { |
95 | return $bind_ref1 == $bind_ref2; |
96 | } else { |
97 | return $bind_ref1 eq $bind_ref2; |
98 | } |
99 | } |
fffe6900 |
100 | } |
101 | |
102 | sub eq_sql { |
103 | my ($left, $right) = @_; |
104 | |
105 | # ignore top-level parentheses |
106 | while ($left->[0] eq 'PAREN') {$left = $left->[1] } |
107 | while ($right->[0] eq 'PAREN') {$right = $right->[1]} |
108 | |
109 | # if operators are different |
110 | if ($left->[0] ne $right->[0]) { |
111 | $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", |
112 | unparse($left), |
113 | unparse($right); |
114 | return 0; |
115 | } |
116 | # elsif operators are identical, compare operands |
117 | else { |
118 | if ($left->[0] eq 'EXPR' ) { # unary operator |
119 | (my $l = " $left->[1] " ) =~ s/\s+/ /g; |
120 | (my $r = " $right->[1] ") =~ s/\s+/ /g; |
121 | my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r); |
122 | $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq; |
123 | return $eq; |
124 | } |
125 | else { # binary operator |
126 | return eq_sql($left->[1][0], $right->[1][0]) # left operand |
127 | && eq_sql($left->[1][1], $right->[1][1]); # right operand |
128 | } |
129 | } |
130 | } |
131 | |
132 | |
133 | sub parse { |
134 | my $s = shift; |
135 | |
136 | # tokenize string |
137 | my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s]; |
138 | |
139 | my $tree = _recurse_parse($tokens); |
140 | return $tree; |
141 | } |
142 | |
143 | sub _recurse_parse { |
144 | my $tokens = shift; |
145 | |
146 | my $left; |
147 | while (1) { # left-associative parsing |
148 | |
149 | my $lookahead = $tokens->[0]; |
150 | return $left if !defined($lookahead) || $lookahead eq ')'; |
151 | |
152 | my $token = shift @$tokens; |
153 | |
154 | # nested expression in () |
155 | if ($token eq '(') { |
156 | my $right = _recurse_parse($tokens); |
157 | $token = shift @$tokens or croak "missing ')'"; |
158 | $token eq ')' or croak "unexpected token : $token"; |
159 | $left = $left ? [CONCAT => [$left, [PAREN => $right]]] |
160 | : [PAREN => $right]; |
161 | } |
162 | # AND/OR |
163 | elsif ($token eq 'AND' || $token eq 'OR') { |
164 | my $right = _recurse_parse($tokens); |
165 | $left = [$token => [$left, $right]]; |
166 | } |
167 | # leaf expression |
168 | else { |
169 | $left = $left ? [CONCAT => [$left, [EXPR => $token]]] |
170 | : [EXPR => $token]; |
171 | } |
172 | } |
173 | } |
174 | |
175 | |
176 | |
177 | sub unparse { |
178 | my $tree = shift; |
179 | my $dispatch = { |
180 | EXPR => sub {$tree->[1] }, |
181 | PAREN => sub {"(" . unparse($tree->[1]) . ")" }, |
182 | CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}}, |
183 | AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}}, |
184 | OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}}, |
185 | }; |
186 | $dispatch->{$tree->[0]}->(); |
187 | } |
188 | |
189 | |
190 | 1; |
191 | |
192 | |
193 | __END__ |
194 | |
195 | =head1 NAME |
196 | |
197 | SQL::Abstract::Test - Helper function for testing SQL::Abstract |
198 | |
199 | =head1 SYNOPSIS |
200 | |
201 | use SQL::Abstract; |
202 | use Test::More; |
5aad8cf3 |
203 | use SQL::Abstract::Test import => ['is_same_sql_bind']; |
fffe6900 |
204 | |
205 | my ($sql, @bind) = SQL::Abstract->new->select(%args); |
206 | is_same_sql_bind($given_sql, \@given_bind, |
207 | $expected_sql, \@expected_bind, $test_msg); |
208 | |
209 | =head1 DESCRIPTION |
210 | |
211 | This module is only intended for authors of tests on |
212 | L<SQL::Abstract|SQL::Abstract> and related modules; |
213 | it exports functions for comparing two SQL statements |
214 | and their bound values. |
215 | |
216 | The SQL comparison is performed on I<abstract syntax>, |
217 | ignoring differences in spaces or in levels of parentheses. |
218 | Therefore the tests will pass as long as the semantics |
219 | is preserved, even if the surface syntax has changed. |
220 | |
221 | B<Disclaimer> : this is only a half-cooked semantic equivalence; |
222 | parsing is simple-minded, and comparison of SQL abstract syntax trees |
223 | ignores commutativity or associativity of AND/OR operators, Morgan |
224 | laws, etc. |
225 | |
226 | =head1 FUNCTIONS |
227 | |
228 | =head2 is_same_sql_bind |
229 | |
230 | is_same_sql_bind($given_sql, \@given_bind, |
231 | $expected_sql, \@expected_bind, $test_msg); |
232 | |
233 | Compares given and expected pairs of C<($sql, \@bind)>, and calls |
a6daa642 |
234 | L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the |
fffe6900 |
235 | test fails, a detailed diagnostic is printed. For clients which use |
a6daa642 |
236 | L<Test::Build>, this is the only function that needs to be |
fffe6900 |
237 | imported. |
238 | |
239 | =head2 eq_sql |
240 | |
241 | my $is_same = eq_sql($given_sql, $expected_sql); |
242 | |
243 | Compares the abstract syntax of two SQL statements. If the result is |
244 | false, global variable L</sql_differ> will contain the SQL portion |
245 | where a difference was encountered; this is useful for printing diagnostics. |
246 | |
247 | =head2 eq_bind |
248 | |
249 | my $is_same = eq_sql(\@given_bind, \@expected_bind); |
250 | |
251 | Compares two lists of bind values, taking into account |
252 | the fact that some of the values may be |
253 | arrayrefs (see L<SQL::Abstract/bindtype>). |
254 | |
255 | =head1 GLOBAL VARIABLES |
256 | |
257 | =head2 case_sensitive |
258 | |
259 | If true, SQL comparisons will be case-sensitive. Default is false; |
260 | |
261 | =head2 sql_differ |
262 | |
263 | When L</eq_sql> returns false, the global variable |
264 | C<$sql_differ> contains the SQL portion |
265 | where a difference was encountered. |
266 | |
267 | |
268 | =head1 SEE ALSO |
269 | |
a6daa642 |
270 | L<SQL::Abstract>, L<Test::More>, L<Test::Builder>. |
fffe6900 |
271 | |
272 | =head1 AUTHOR |
273 | |
274 | Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt> |
275 | |
276 | =head1 COPYRIGHT AND LICENSE |
277 | |
278 | Copyright 2008 by Laurent Dami. |
279 | |
280 | This library is free software; you can redistribute it and/or modify |
281 | it under the same terms as Perl itself. |