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