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; |
cbcfedc1 |
11 | use SQL::Abstract::Types qw/AST ArrayAST HashAST/; |
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'), |
a464be15 |
22 | and => $self->can('_recurse_where'), |
23 | or => $self->can('_recurse_where'), |
1b85673a |
24 | map { +"$_" => $self->can("_$_") } qw/ |
0c371882 |
25 | value |
26 | name |
27 | true |
28 | false |
e7996b3a |
29 | expr |
0c371882 |
30 | / |
0bf8a8c4 |
31 | }; |
14774be0 |
32 | } |
33 | |
cbcfedc1 |
34 | method _select(HashAST $ast) { |
747f7c21 |
35 | # Default to requiring columns and from. |
36 | # DB specific ones (i.e. mysql/Pg) can not require the FROM part with a bit |
37 | # of refactoring |
38 | |
39 | for (qw/columns tablespec/) { |
40 | confess "'$_' is required in select AST with " . dump ($ast) |
41 | unless exists $ast->{$_}; |
4ee32f41 |
42 | } |
43 | |
44 | # Check that columns is a -list |
747f7c21 |
45 | confess "'columns' should be an array ref, not " . dump($ast->{columns}) |
46 | unless is_ArrayRef($ast->{columns}); |
47 | |
64c32031 |
48 | my $cols = $self->_list({-type => 'list', args => $ast->{columns} }); |
4ee32f41 |
49 | |
50 | my @output = ( |
747f7c21 |
51 | SELECT => $cols |
4ee32f41 |
52 | ); |
53 | |
747f7c21 |
54 | push @output, FROM => $self->dispatch($ast->{tablespec}) |
55 | if exists $ast->{tablespec}; |
56 | |
e68f980b |
57 | for (qw/where having group_by/) { |
4ee32f41 |
58 | if (exists $ast->{$_}) { |
59 | my $sub_ast = $ast->{$_}; |
e68f980b |
60 | |
61 | confess "$_ option is not an AST: " . dump($sub_ast) |
4ee32f41 |
62 | unless is_AST($sub_ast); |
63 | |
e68f980b |
64 | my $meth = "__$_"; |
65 | push @output, $self->$meth($sub_ast); |
4ee32f41 |
66 | } |
67 | } |
68 | |
69 | return join(' ', @output); |
14774be0 |
70 | } |
71 | |
64c32031 |
72 | method _join(HashRef $ast) { |
d0ad3a92 |
73 | |
74 | # TODO: Validate join type |
75 | my $type = $ast->{join_type} || ""; |
14774be0 |
76 | |
f7dc4536 |
77 | my @output = $self->dispatch($ast->{lhs}); |
d0ad3a92 |
78 | |
79 | push @output, uc $type if $type; |
f7dc4536 |
80 | push @output, "JOIN", $self->dispatch($ast->{rhs}); |
64c32031 |
81 | |
d0ad3a92 |
82 | push @output, |
83 | exists $ast->{on} |
84 | ? ('ON', '(' . $self->_expr( $ast->{on} ) . ')' ) |
85 | : ('USING', '(' .$self->dispatch($ast->{using} || croak "No 'on' or 'join' clause passed to -join"). |
86 | ')' ); |
64c32031 |
87 | |
d0ad3a92 |
88 | return join(" ", @output); |
64c32031 |
89 | |
14774be0 |
90 | } |
91 | |
7a56723e |
92 | method _order_by(AST $ast) { |
93 | my @clauses = @{$ast->{order_by}}; |
94 | |
14774be0 |
95 | my @output; |
96 | |
97 | for (@clauses) { |
7a56723e |
98 | if (is_ArrayRef($_) && $_->[0] =~ /^-(asc|desc)$/) { |
14774be0 |
99 | my $o = $1; |
100 | push @output, $self->dispatch($_->[1]) . " " . uc($o); |
101 | next; |
102 | } |
103 | push @output, $self->dispatch($_); |
104 | } |
105 | |
106 | return "ORDER BY " . join(", ", @output); |
107 | } |
108 | |
747f7c21 |
109 | method _name(HashAST $ast) { |
7a56723e |
110 | my @names = @{$ast->{args}}; |
14774be0 |
111 | |
112 | my $sep = $self->name_separator; |
4ee32f41 |
113 | my $quote = $self->is_quoting |
114 | ? $self->quote_chars |
115 | : [ '' ]; |
116 | |
117 | my $join = $quote->[-1] . $sep . $quote->[0]; |
14774be0 |
118 | |
4ee32f41 |
119 | # We dont want to quote * in [qw/me */]: `me`.* is the desired output there |
120 | # This means you can't have a field called `*`. I am willing to accept this |
121 | # situation, cos thats a really stupid thing to want. |
122 | my $post; |
123 | $post = pop @names if $names[-1] eq '*'; |
14774be0 |
124 | |
4ee32f41 |
125 | my $ret = |
126 | $quote->[0] . |
127 | join( $join, @names ) . |
128 | $quote->[-1]; |
129 | |
130 | $ret .= $sep . $post if defined $post; |
131 | return $ret; |
14774be0 |
132 | } |
133 | |
14774be0 |
134 | |
7a56723e |
135 | method _list(AST $ast) { |
136 | my @items = @{$ast->{args}}; |
14774be0 |
137 | |
138 | return join( |
139 | $self->list_separator, |
140 | map { $self->dispatch($_) } @items); |
141 | } |
142 | |
747f7c21 |
143 | # TODO: I think i want to parameterized AST type to get better validation |
7a56723e |
144 | method _alias(AST $ast) { |
145 | |
4ee32f41 |
146 | # TODO: Maybe we want qq{ AS "$as"} here |
7a56723e |
147 | return $self->dispatch($ast->{ident}) . " AS " . $ast->{as}; |
14774be0 |
148 | |
149 | } |
150 | |
1b85673a |
151 | method _value(HashAST $ast) { |
14774be0 |
152 | |
1b85673a |
153 | $self->add_bind($ast->{value}); |
14774be0 |
154 | return "?"; |
155 | } |
156 | |
e68f980b |
157 | # Not dispatchable to. |
158 | method __where(HashAST $ast) { |
159 | return "WHERE " . $self->_expr($ast); |
160 | } |
161 | |
ef0d6124 |
162 | # Perhaps badly named. handles 'and' and 'or' clauses |
a464be15 |
163 | method _recurse_where(HashAST $ast) { |
14774be0 |
164 | |
a464be15 |
165 | my $op = $ast->{op}; |
14774be0 |
166 | |
a464be15 |
167 | my $OP = uc $op; |
168 | my $prio = $SQL::Abstract::PRIO{$op}; |
14774be0 |
169 | |
ef0d6124 |
170 | my $dispatch_table = $self->expr_dispatch_table; |
0bf8a8c4 |
171 | |
14774be0 |
172 | my @output; |
a464be15 |
173 | foreach ( @{$ast->{args}} ) { |
e7996b3a |
174 | croak "invalid component in where clause: $_" unless is_HashAST($_); |
14774be0 |
175 | |
9d7d0694 |
176 | if ($_->{-type} eq 'expr' && $_->{op} =~ /^(and|or)$/) { |
14774be0 |
177 | my $sub_prio = $SQL::Abstract::PRIO{$1}; |
178 | |
179 | if ($sub_prio <= $prio) { |
180 | push @output, $self->_recurse_where($_); |
181 | } else { |
182 | push @output, '(' . $self->_recurse_where($_) . ')'; |
183 | } |
184 | } else { |
ef0d6124 |
185 | push @output, $self->_expr($_); |
14774be0 |
186 | } |
187 | } |
188 | |
189 | return join(" $OP ", @output); |
190 | } |
191 | |
ef0d6124 |
192 | method _expr(HashAST $ast) { |
1b85673a |
193 | my $op = $ast->{-type}; |
0c371882 |
194 | |
ef0d6124 |
195 | $op = $ast->{op} if $op eq 'expr'; |
196 | |
197 | if (my $code = $self->lookup_expr_dispatch($op)) { |
0c371882 |
198 | |
199 | return $code->($self, $ast); |
200 | |
201 | } |
ef0d6124 |
202 | croak "'$op' is not a valid AST type in an expression with " . dump($ast) |
203 | if $ast->{-type} ne 'expr'; |
0c371882 |
204 | |
ef0d6124 |
205 | croak "'$op' is not a valid operator in an expression with " . dump($ast); |
1b85673a |
206 | |
1b85673a |
207 | } |
0c371882 |
208 | |
1b85673a |
209 | method _binop(HashAST $ast) { |
210 | my ($lhs, $rhs) = @{$ast->{args}}; |
211 | my $op = $ast->{op}; |
0bf8a8c4 |
212 | |
ef0d6124 |
213 | join (' ', $self->_expr($lhs), |
0bf8a8c4 |
214 | $self->binop_mapping($op) || croak("Unknown binary operator $op"), |
ef0d6124 |
215 | $self->_expr($rhs) |
14774be0 |
216 | ); |
217 | } |
218 | |
a464be15 |
219 | method _in(HashAST $ast) { |
220 | |
9d7d0694 |
221 | my ($field,@values) = @{$ast->{args}}; |
a464be15 |
222 | |
9d7d0694 |
223 | my $not = ($ast->{op} =~ /^not_/) ? " NOT" : ""; |
0bf8a8c4 |
224 | |
9d7d0694 |
225 | return $self->_false unless @values; |
14774be0 |
226 | |
ef0d6124 |
227 | return $self->_expr($field) . |
9d7d0694 |
228 | $not . |
14774be0 |
229 | " IN (" . |
9d7d0694 |
230 | join(", ", map { $self->dispatch($_) } @values ) . |
14774be0 |
231 | ")"; |
232 | } |
233 | |
234 | method _generic_func(ArrayRef $ast) { |
235 | } |
236 | |
44cfd1f6 |
237 | # 'constants' that are portable across DBs |
238 | method _false($ast?) { "0 = 1" } |
239 | method _true($ast?) { "1 = 1" } |
240 | |
14774be0 |
241 | } |