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