Commit | Line | Data |
14774be0 |
1 | use MooseX::Declare; |
2 | |
3 | class SQL::Abstract::AST::v1 extends SQL::Abstract { |
4 | |
5 | use Carp qw/croak/; |
6 | use Data::Dump qw/pp/; |
7 | |
8 | use Moose::Util::TypeConstraints; |
cbcfedc1 |
9 | use MooseX::Types::Moose qw/ArrayRef Str Int Ref HashRef/; |
14774be0 |
10 | use MooseX::AttributeHelpers; |
bad761ba |
11 | use SQL::Abstract::Types qw/AST/; |
ef0d6124 |
12 | use Devel::PartialDump qw/dump/; |
14774be0 |
13 | |
14 | clean; |
15 | |
0c371882 |
16 | # set things that are valid in where clauses |
ef0d6124 |
17 | override _build_expr_dispatch_table { |
0bf8a8c4 |
18 | return { |
19 | %{super()}, |
1b85673a |
20 | in => $self->can('_in'), |
21 | not_in => $self->can('_in'), |
1f4bd99c |
22 | between => $self->can('_between'), |
23 | not_between => $self->can('_between'), |
a464be15 |
24 | and => $self->can('_recurse_where'), |
25 | or => $self->can('_recurse_where'), |
1b85673a |
26 | map { +"$_" => $self->can("_$_") } qw/ |
0c371882 |
27 | value |
627dcb62 |
28 | identifier |
0c371882 |
29 | true |
30 | false |
e7996b3a |
31 | expr |
0c371882 |
32 | / |
0bf8a8c4 |
33 | }; |
14774be0 |
34 | } |
35 | |
bad761ba |
36 | method _select(AST $ast) { |
747f7c21 |
37 | # Default to requiring columns and from. |
38 | # DB specific ones (i.e. mysql/Pg) can not require the FROM part with a bit |
39 | # of refactoring |
40 | |
41 | for (qw/columns tablespec/) { |
42 | confess "'$_' is required in select AST with " . dump ($ast) |
43 | unless exists $ast->{$_}; |
4ee32f41 |
44 | } |
45 | |
46 | # Check that columns is a -list |
747f7c21 |
47 | confess "'columns' should be an array ref, not " . dump($ast->{columns}) |
48 | unless is_ArrayRef($ast->{columns}); |
49 | |
64c32031 |
50 | my $cols = $self->_list({-type => 'list', args => $ast->{columns} }); |
4ee32f41 |
51 | |
52 | my @output = ( |
747f7c21 |
53 | SELECT => $cols |
4ee32f41 |
54 | ); |
55 | |
747f7c21 |
56 | push @output, FROM => $self->dispatch($ast->{tablespec}) |
57 | if exists $ast->{tablespec}; |
58 | |
924d940e |
59 | if (exists $ast->{where}) { |
60 | my $sub_ast = $ast->{where}; |
61 | |
62 | confess "$_ option is not an AST: " . dump($sub_ast) |
63 | unless is_AST($sub_ast); |
64 | |
65 | push @output, "WHERE", $self->_expr($sub_ast); |
66 | } |
67 | |
68 | for (qw/group_by having order_by/) { |
4ee32f41 |
69 | if (exists $ast->{$_}) { |
70 | my $sub_ast = $ast->{$_}; |
e68f980b |
71 | |
924d940e |
72 | confess "$_ option is not an AST or an ArrayRef: " . dump($sub_ast) |
73 | unless is_AST($sub_ast) || is_ArrayRef($sub_ast);; |
4ee32f41 |
74 | |
e68f980b |
75 | my $meth = "__$_"; |
76 | push @output, $self->$meth($sub_ast); |
4ee32f41 |
77 | } |
78 | } |
79 | |
80 | return join(' ', @output); |
14774be0 |
81 | } |
82 | |
d4656fcf |
83 | method _update(AST $ast) { |
84 | |
85 | for (qw/columns values tablespec/) { |
86 | confess "'$_' is required in update AST with " . dump ($ast) |
87 | unless exists $ast->{$_}; |
88 | } |
fc20481d |
89 | |
90 | my $table = $ast->{tablespec}; |
91 | confess 'update: tablespec must be an ident or an alias in ' . dump($ast) |
92 | unless $table->{-type} =~ /^identifier|alias$/; |
93 | |
94 | my @output = ( |
95 | 'UPDATE', |
96 | $self->dispatch($table), |
97 | 'SET' |
98 | ); |
99 | |
99124578 |
100 | confess 'update: Number of values does not match columns: ' . dump($ast) |
fc20481d |
101 | if @{$ast->{columns}} != @{$ast->{values}}; |
102 | |
fc20481d |
103 | my $list = { |
104 | -type => 'list', |
105 | args => [ map { |
106 | { -type => 'expr', |
107 | op => '==', # This should really be '=' but hmmmmmmmm |
108 | args => [ |
109 | $ast->{columns}[$_], |
110 | $ast->{values}[$_] |
111 | ] |
112 | } |
113 | } 0..$#{$ast->{columns}} ] |
114 | }; |
115 | |
116 | push @output, $self->dispatch($list); |
117 | |
118 | return join(' ', @output); |
d4656fcf |
119 | |
120 | } |
121 | |
64c32031 |
122 | method _join(HashRef $ast) { |
d0ad3a92 |
123 | |
124 | # TODO: Validate join type |
125 | my $type = $ast->{join_type} || ""; |
14774be0 |
126 | |
f7dc4536 |
127 | my @output = $self->dispatch($ast->{lhs}); |
d0ad3a92 |
128 | |
129 | push @output, uc $type if $type; |
f7dc4536 |
130 | push @output, "JOIN", $self->dispatch($ast->{rhs}); |
64c32031 |
131 | |
d0ad3a92 |
132 | push @output, |
133 | exists $ast->{on} |
134 | ? ('ON', '(' . $self->_expr( $ast->{on} ) . ')' ) |
924d940e |
135 | : ('USING', '(' .$self->dispatch($ast->{using} |
136 | || croak "No 'on' or 'uinsg' clause passed to join cluase: " . |
137 | dump($ast) |
138 | ) . |
d0ad3a92 |
139 | ')' ); |
64c32031 |
140 | |
d0ad3a92 |
141 | return join(" ", @output); |
64c32031 |
142 | |
14774be0 |
143 | } |
144 | |
924d940e |
145 | method _ordering(AST $ast) { |
146 | |
147 | my $output = $self->_expr($ast->{expr}); |
148 | |
149 | $output .= " " . uc $1 |
150 | if $ast->{direction} && |
151 | ( $ast->{direction} =~ /^(asc|desc)$/i |
152 | || confess "Unknown ordering direction " . dump($ast) |
153 | ); |
14774be0 |
154 | |
924d940e |
155 | return $output; |
14774be0 |
156 | } |
157 | |
627dcb62 |
158 | method _identifier(AST $ast) { |
159 | my @names = @{$ast->{elements}}; |
14774be0 |
160 | |
627dcb62 |
161 | my $sep = $self->ident_separator; |
4ee32f41 |
162 | my $quote = $self->is_quoting |
163 | ? $self->quote_chars |
164 | : [ '' ]; |
165 | |
166 | my $join = $quote->[-1] . $sep . $quote->[0]; |
14774be0 |
167 | |
4ee32f41 |
168 | # We dont want to quote * in [qw/me */]: `me`.* is the desired output there |
169 | # This means you can't have a field called `*`. I am willing to accept this |
170 | # situation, cos thats a really stupid thing to want. |
171 | my $post; |
172 | $post = pop @names if $names[-1] eq '*'; |
14774be0 |
173 | |
8b398780 |
174 | my $ret; |
175 | $ret = $quote->[0] . |
176 | join( $join, @names ) . |
177 | $quote->[-1] |
178 | if @names; |
179 | |
180 | $ret = $ret |
181 | ? $ret . $sep . $post |
182 | : $post |
183 | if defined $post; |
184 | |
4ee32f41 |
185 | |
4ee32f41 |
186 | return $ret; |
14774be0 |
187 | } |
188 | |
14774be0 |
189 | |
7a56723e |
190 | method _list(AST $ast) { |
e6a33ce3 |
191 | return "" unless $ast->{args}; |
192 | |
924d940e |
193 | my @items = is_ArrayRef($ast->{args}) |
194 | ? @{$ast->{args}} |
195 | : $ast->{args}; |
14774be0 |
196 | |
197 | return join( |
198 | $self->list_separator, |
199 | map { $self->dispatch($_) } @items); |
200 | } |
201 | |
747f7c21 |
202 | # TODO: I think i want to parameterized AST type to get better validation |
7a56723e |
203 | method _alias(AST $ast) { |
204 | |
4ee32f41 |
205 | # TODO: Maybe we want qq{ AS "$as"} here |
7a56723e |
206 | return $self->dispatch($ast->{ident}) . " AS " . $ast->{as}; |
14774be0 |
207 | |
208 | } |
209 | |
bad761ba |
210 | method _value(AST $ast) { |
14774be0 |
211 | |
1b85673a |
212 | $self->add_bind($ast->{value}); |
14774be0 |
213 | return "?"; |
214 | } |
215 | |
e68f980b |
216 | # Not dispatchable to. |
924d940e |
217 | method __having($args) { |
218 | return "HAVING " . $self->_list({-type => 'list', args => $args}); |
219 | } |
220 | |
221 | method __group_by($args) { |
222 | return "GROUP BY " . $self->_list({-type => 'list', args => $args}); |
e68f980b |
223 | } |
224 | |
924d940e |
225 | method __order_by($args) { |
226 | return "ORDER BY " . $self->_list({-type => 'list', args => $args}); |
227 | } |
228 | |
229 | |
ef0d6124 |
230 | # Perhaps badly named. handles 'and' and 'or' clauses |
bad761ba |
231 | method _recurse_where(AST $ast) { |
14774be0 |
232 | |
a464be15 |
233 | my $op = $ast->{op}; |
14774be0 |
234 | |
a464be15 |
235 | my $OP = uc $op; |
236 | my $prio = $SQL::Abstract::PRIO{$op}; |
14774be0 |
237 | |
ef0d6124 |
238 | my $dispatch_table = $self->expr_dispatch_table; |
0bf8a8c4 |
239 | |
14774be0 |
240 | my @output; |
a464be15 |
241 | foreach ( @{$ast->{args}} ) { |
bad761ba |
242 | croak "invalid component in where clause: $_" unless is_AST($_); |
14774be0 |
243 | |
9d7d0694 |
244 | if ($_->{-type} eq 'expr' && $_->{op} =~ /^(and|or)$/) { |
14774be0 |
245 | my $sub_prio = $SQL::Abstract::PRIO{$1}; |
246 | |
39f7dc30 |
247 | if ($sub_prio == $prio) { |
248 | # When the element below has same priority, i.e. 'or' as a child of |
249 | # 'or', dont produce extra brackets |
14774be0 |
250 | push @output, $self->_recurse_where($_); |
251 | } else { |
252 | push @output, '(' . $self->_recurse_where($_) . ')'; |
253 | } |
254 | } else { |
ef0d6124 |
255 | push @output, $self->_expr($_); |
14774be0 |
256 | } |
257 | } |
258 | |
259 | return join(" $OP ", @output); |
260 | } |
261 | |
bad761ba |
262 | method _expr(AST $ast) { |
1b85673a |
263 | my $op = $ast->{-type}; |
0c371882 |
264 | |
ef0d6124 |
265 | $op = $ast->{op} if $op eq 'expr'; |
266 | |
267 | if (my $code = $self->lookup_expr_dispatch($op)) { |
0c371882 |
268 | |
269 | return $code->($self, $ast); |
270 | |
271 | } |
ef0d6124 |
272 | croak "'$op' is not a valid AST type in an expression with " . dump($ast) |
273 | if $ast->{-type} ne 'expr'; |
0c371882 |
274 | |
e6a33ce3 |
275 | # This is an attempt to do some form of validation on function names. This |
276 | # might end up being a bad thing. |
277 | croak "'$op' is not a valid operator in an expression with " . dump($ast) |
278 | if $op =~ /\W/; |
279 | |
280 | return $self->_generic_function_op($ast); |
1b85673a |
281 | |
1b85673a |
282 | } |
0c371882 |
283 | |
bad761ba |
284 | method _binop(AST $ast) { |
1b85673a |
285 | my ($lhs, $rhs) = @{$ast->{args}}; |
286 | my $op = $ast->{op}; |
0bf8a8c4 |
287 | |
ec376489 |
288 | # IS NOT? NULL |
289 | if ($rhs->{-type} eq 'value' && !defined $rhs->{value} && |
290 | ($op eq '==' || $op eq '!=')) |
291 | { |
292 | return $self->_expr($lhs) . |
293 | ($op eq '==' ? " IS " : " IS NOT ") . |
294 | "NULL"; |
295 | } |
296 | |
ef0d6124 |
297 | join (' ', $self->_expr($lhs), |
0bf8a8c4 |
298 | $self->binop_mapping($op) || croak("Unknown binary operator $op"), |
ef0d6124 |
299 | $self->_expr($rhs) |
14774be0 |
300 | ); |
301 | } |
302 | |
e6a33ce3 |
303 | method _generic_function_op(AST $ast) { |
304 | my $op = $ast->{op}; |
305 | |
306 | return "$op(" . $self->_list($ast) . ")"; |
307 | } |
308 | |
bad761ba |
309 | method _in(AST $ast) { |
a464be15 |
310 | |
9d7d0694 |
311 | my ($field,@values) = @{$ast->{args}}; |
a464be15 |
312 | |
9d7d0694 |
313 | my $not = ($ast->{op} =~ /^not_/) ? " NOT" : ""; |
0bf8a8c4 |
314 | |
9d7d0694 |
315 | return $self->_false unless @values; |
14774be0 |
316 | |
ef0d6124 |
317 | return $self->_expr($field) . |
9d7d0694 |
318 | $not . |
14774be0 |
319 | " IN (" . |
9d7d0694 |
320 | join(", ", map { $self->dispatch($_) } @values ) . |
14774be0 |
321 | ")"; |
322 | } |
323 | |
1f4bd99c |
324 | method _between(AST $ast) { |
325 | |
326 | my ($field,@values) = @{$ast->{args}}; |
327 | |
328 | my $not = ($ast->{op} =~ /^not_/) ? " NOT" : ""; |
329 | croak "between requires 3 arguments: " . dump($ast) |
330 | unless @values == 2; |
331 | |
39f7dc30 |
332 | # The brackets are to work round an issue with SQL::A::Test |
333 | return "(" . |
334 | $self->_expr($field) . |
1f4bd99c |
335 | $not . |
336 | " BETWEEN " . |
39f7dc30 |
337 | join(" AND ", map { $self->dispatch($_) } @values ) . |
338 | ")"; |
1f4bd99c |
339 | } |
340 | |
44cfd1f6 |
341 | # 'constants' that are portable across DBs |
342 | method _false($ast?) { "0 = 1" } |
343 | method _true($ast?) { "1 = 1" } |
344 | |
14774be0 |
345 | } |