Commit | Line | Data |
515523bc |
1 | package Data::Query::Renderer::SQL::Naive; |
2 | |
3 | use strictures 1; |
4 | use SQL::ReservedWords; |
bdb576cb |
5 | use Data::Query::Constants qw( |
f3f803da |
6 | DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE DQ_JOIN DQ_ALIAS DQ_ORDER DQ_LITERAL |
bdb576cb |
7 | ); |
515523bc |
8 | |
9 | sub new { |
10 | bless({ %{$_[1]||{}} }, (ref($_[0])||$_[0]))->BUILDALL; |
11 | } |
12 | |
13 | sub BUILDALL { |
14 | my $self = shift; |
15 | $self->{reserved_ident_parts} |
16 | ||= ( |
17 | our $_DEFAULT_RESERVED ||= { map +($_ => 1), SQL::ReservedWords->words } |
18 | ); |
19 | $self->{quote_chars}||=['']; |
20 | $self->{simple_ops}||=$self->_default_simple_ops; |
21 | return $self; |
22 | } |
23 | |
24 | sub _default_simple_ops { |
25 | +{ |
f8343502 |
26 | (map +($_ => 'binop'), qw(= > < >= <= != LIKE), 'NOT LIKE' ), |
27 | (map +($_ => 'unop'), qw(NOT) ), |
28 | (map +($_ => 'unop_reverse'), ('IS NULL', 'IS NOT NULL')), |
515523bc |
29 | (map +($_ => 'flatten'), qw(AND OR) ), |
f8343502 |
30 | (map +($_ => 'in'), ('IN', 'NOT IN')), |
829906e0 |
31 | (map +($_ => 'between'), ('BETWEEN', 'NOT BETWEEN')), |
32 | (apply => 'apply'), |
515523bc |
33 | } |
34 | } |
35 | |
36 | sub render { |
37 | my $self = shift; |
38 | $self->_flatten_structure($self->_render(@_)) |
39 | } |
40 | |
41 | sub _flatten_structure { |
42 | my ($self, $struct) = @_; |
43 | my @bind; |
bdb576cb |
44 | [ do { |
45 | my @p = map { |
46 | my $r = ref; |
47 | if (!$r) { $_ } |
48 | elsif ($r eq 'ARRAY') { |
49 | my ($sql, @b) = @{$self->_flatten_structure($_)}; |
50 | push @bind, @b; |
51 | $sql; |
52 | } |
53 | elsif ($r eq 'HASH') { push @bind, $_; () } |
54 | else { die "_flatten_structure can't handle ref type $r for $_" } |
55 | } @$struct; |
56 | join '', map { |
57 | ($p[$_], (($p[$_+1]||',') eq ',') ? () : (' ')) |
58 | } 0 .. $#p; |
59 | }, |
60 | @bind |
61 | ]; |
515523bc |
62 | } |
63 | |
04d30ecb |
64 | # I presented this to permit strange people to easily supply a patch to lc() |
9c8fc055 |
65 | # their keywords, as I have heard many desire to do, lest they infect me |
66 | # with whatever malady caused this desire by their continued proximity for |
67 | # want of such a feature. |
04d30ecb |
68 | # |
69 | # Then I realised that SQL::Abstract compatibility work required it. |
70 | # |
71 | # FEH. |
9c8fc055 |
72 | |
04d30ecb |
73 | sub _format_keyword { $_[0]->{lc_keywords} ? lc($_[1]) : $_[1] } |
9c8fc055 |
74 | |
515523bc |
75 | sub _render { |
bdb576cb |
76 | $_[0]->${\"_render_${\(lc($_[1]->{type})||'broken')}"}($_[1]); |
77 | } |
78 | |
79 | sub _render_broken { |
80 | my ($self, $dq) = @_; |
81 | require Data::Dumper::Concise; |
82 | die "Broken DQ entry: ".Data::Dumper::Concise::Dumper($dq); |
515523bc |
83 | } |
84 | |
85 | sub _render_identifier { |
86 | die "Unidentified identifier (SQL can no has \$_)" |
87 | unless my @i = @{$_[1]->{elements}}; |
88 | # handle single or paired quote chars |
89 | my ($q1, $q2) = @{$_[0]->{quote_chars}}[0,-1]; |
90 | my $always_quote = $_[0]->{always_quote}; |
91 | my $res_check = $_[0]->{reserved_ident_parts}; |
92 | return [ |
93 | join |
94 | $_[0]->{identifier_sep}||'.', |
95 | map +( |
96 | $_ eq '*' # Yes, this means you can't have a column just called '*'. |
97 | ? $_ # Yes, this is a feature. Go shoot the DBA if he disagrees. |
98 | : ( # reserved are stored uc, quote if non-word |
99 | $always_quote || $res_check->{+uc} || /\W/ |
100 | ? $q1.$_.$q2 |
101 | : $_ |
102 | ) |
103 | ), @i |
104 | ]; |
105 | } |
106 | |
107 | sub _render_value { |
829906e0 |
108 | defined($_[1]->{value}) |
109 | ? [ '?', $_[1] ] |
110 | : [ 'NULL' ]; |
515523bc |
111 | } |
112 | |
12e6eab8 |
113 | sub _operator_type { 'SQL.Naive' } |
114 | |
515523bc |
115 | sub _render_operator { |
116 | my ($self, $dq) = @_; |
117 | my $op = $dq->{operator}; |
12e6eab8 |
118 | unless (exists $op->{$self->_operator_type}) { |
119 | $op->{$self->_operator_type} = $self->_convert_op($dq); |
515523bc |
120 | } |
f8343502 |
121 | my $op_name = $op->{$self->_operator_type}; |
122 | if (my $op_type = $self->{simple_ops}{$op_name}) { |
515523bc |
123 | return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq); |
f8343502 |
124 | } elsif (my $meth = $self->can("_handle_op_special_${op_name}")) { |
125 | return $self->$meth($dq); |
515523bc |
126 | } |
6e055841 |
127 | if (my $argc = @{$dq->{args}}) { |
128 | if ($argc == 1) { |
129 | return $self->_handle_op_type_unop($op_name, $dq); |
130 | } elsif ($argc == 2) { |
131 | return $self->_handle_op_type_binop($op_name, $dq); |
132 | } |
133 | } |
134 | die "Unsure how to handle ${op_name}"; |
515523bc |
135 | } |
136 | |
137 | sub _handle_op_type_binop { |
138 | my ($self, $op_name, $dq) = @_; |
139 | die "${op_name} registered as binary op but args contain " |
140 | .scalar(@{$dq->{args}})." entries" |
141 | unless @{$dq->{args}} == 2; |
142 | [ |
143 | $self->_render($dq->{args}[0]), |
144 | $op_name, |
145 | $self->_render($dq->{args}[1]), |
146 | ] |
147 | } |
148 | |
149 | sub _handle_op_type_unop { |
150 | my ($self, $op_name, $dq) = @_; |
151 | die "${op_name} registered as unary op but args contain " |
152 | .scalar(@{$dq->{args}})." entries" |
153 | unless @{$dq->{args}} == 1; |
154 | [ |
f8343502 |
155 | '(', |
156 | $op_name, |
157 | $self->_render($dq->{args}[0]), |
158 | ')', |
159 | ] |
160 | } |
161 | |
162 | sub _handle_op_type_unop_reverse { |
163 | my ($self, $op_name, $dq) = @_; |
164 | die "${op_name} registered as unary op but args contain " |
165 | .scalar(@{$dq->{args}})." entries" |
166 | unless @{$dq->{args}} == 1; |
167 | [ |
515523bc |
168 | $self->_render($dq->{args}[0]), |
f8343502 |
169 | $op_name, |
515523bc |
170 | ] |
171 | } |
172 | |
173 | sub _handle_op_type_flatten { |
174 | my ($self, $op_name, $dq) = @_; |
175 | my @argq = @{$dq->{args}}; |
176 | my @arg_final; |
177 | while (my $arg = shift @argq) { |
178 | |
179 | unless ($arg->{type} eq DQ_OPERATOR) { |
180 | push @arg_final, $arg; |
181 | next; |
182 | } |
183 | |
184 | my $op = $arg->{operator}; |
12e6eab8 |
185 | unless (exists $op->{$self->_operator_type}) { |
186 | $op->{$self->_operator_type} = $self->_convert_op($arg); |
515523bc |
187 | } |
188 | |
12e6eab8 |
189 | if ($op->{$self->_operator_type} eq $op_name) { |
515523bc |
190 | unshift @argq, @{$arg->{args}}; |
191 | } else { |
192 | push @arg_final, $arg; |
193 | } |
194 | } |
195 | my @sql = ('(', map +($self->_render($_), $op_name), @arg_final); |
196 | $sql[-1] = ')'; # replace final AND or whatever with ) |
197 | \@sql; |
198 | } |
199 | |
f8343502 |
200 | sub _handle_op_type_in { |
201 | my ($self, $op, $dq) = @_; |
202 | my ($lhs, @in) = @{$dq->{args}}; |
203 | my @rhs = ('(', map +($self->_render($_), ','), @in); |
204 | $rhs[-1] = ')'; |
205 | [ $self->_render($lhs), $op, @rhs ]; |
206 | } |
207 | |
208 | sub _handle_op_type_between { |
209 | my ($self, $op_name, $dq) = @_; |
f3f803da |
210 | my @args = @{$dq->{args}}; |
211 | if (@args == 3) { |
212 | my ($lhs, $rhs1, $rhs2) = (map $self->_render($_), @args); |
839687b2 |
213 | [ '(', $lhs, $op_name, $rhs1, 'AND', $rhs2, ')' ]; |
f3f803da |
214 | } elsif (@args == 2 and $args[1]->{type} eq DQ_LITERAL) { |
215 | my ($lhs, $rhs) = (map $self->_render($_), @args); |
839687b2 |
216 | [ '(', $lhs, $op_name, $rhs, ')' ]; |
f3f803da |
217 | } else { |
218 | die "Invalid args for between: ${\scalar @args} given"; |
219 | } |
f8343502 |
220 | } |
221 | |
829906e0 |
222 | sub _handle_op_type_apply { |
223 | my ($self, $op_name, $dq) = @_; |
224 | my ($func, @args) = @{$dq->{args}}; |
225 | die "Function name must be identifier" |
226 | unless $func->{type} eq DQ_IDENTIFIER; |
54a46537 |
227 | my $ident = do { |
228 | # The problem we have here is that built-ins can't be quoted, generally. |
229 | # I rather wonder if things like MAX(...) need to -not- be handled as |
230 | # an apply and instead of something else, maybe a parenop type - but |
231 | # as an explicitly Naive renderer this seems like a reasonable answer. |
232 | local @{$self}{qw(reserved_ident_parts always_quote)}; |
233 | $self->_render_identifier($func)->[0]; |
234 | }; |
829906e0 |
235 | [ |
236 | "$ident(", |
237 | (map $self->_render($_), @args), |
238 | ')' |
239 | ] |
240 | } |
241 | |
515523bc |
242 | sub _convert_op { |
243 | my ($self, $dq) = @_; |
244 | if (my $perl_op = $dq->{'operator'}->{'Perl'}) { |
245 | for ($perl_op) { |
246 | $_ eq '==' and return '='; |
247 | $_ eq 'eq' and return '='; |
248 | $_ eq '!' and return 'NOT'; |
249 | } |
250 | return uc $perl_op; # hope! |
251 | } |
252 | die "Can't convert non-perl op yet"; |
253 | } |
9c8fc055 |
254 | |
255 | sub _render_select { |
256 | my ($self, $dq) = @_; |
257 | die "Empty select list" unless @{$dq->{select}}; |
258 | |
259 | # it is, in fact, completely valid for there to be nothing for us |
260 | # to project from since many databases handle 'SELECT 1;' fine |
261 | |
bdb576cb |
262 | my @select = map [ |
263 | ($_->{type} eq DQ_ALIAS |
7f462f86 |
264 | ? $self->_render_alias($_, $self->_format_keyword('AS')) |
bdb576cb |
265 | : $self->_render($_) |
266 | ), |
267 | ',' |
268 | ], @{$dq->{select}}; |
9c8fc055 |
269 | |
270 | # we put the commas inside the [] for each entry as a hint to the pretty |
bdb576cb |
271 | # printer downstream so now we need to eliminate the comma from the last |
9c8fc055 |
272 | # entry - we know there always is one due to the die guard at the top |
273 | |
274 | pop @{$select[-1]}; |
275 | |
276 | return [ |
277 | $self->_format_keyword('SELECT'), |
278 | \@select, |
279 | # if present this may be a bare FROM, a FROM+WHERE, or a FROM+WHERE+GROUP |
280 | # since we're the SELECT and therefore always come first, we don't care. |
2cf0bb42 |
281 | ($dq->{from} |
282 | ? ($self->_format_keyword('FROM'), @{$self->_render($dq->{from})}) |
283 | : () |
284 | ) |
285 | ]; |
286 | } |
287 | |
288 | sub _render_alias { |
bdb576cb |
289 | my ($self, $dq, $as) = @_; |
2cf0bb42 |
290 | # FROM foo foo -> FROM foo |
291 | # FROM foo.bar bar -> FROM foo.bar |
292 | if ($dq->{alias}{type} eq DQ_IDENTIFIER) { |
293 | if ($dq->{alias}{elements}[-1] eq $dq->{as}) { |
294 | return $self->_render($dq->{alias}); |
295 | } |
296 | } |
297 | return [ |
298 | $self->_render($dq->{alias}), |
bdb576cb |
299 | $as || ' ', |
2cf0bb42 |
300 | $self->_render_identifier({ elements => [ $dq->{as} ] }) |
301 | ]; |
302 | } |
303 | |
304 | sub _render_literal { |
305 | my ($self, $dq) = @_; |
306 | unless ($dq->{subtype} eq 'SQL') { |
307 | die "Can't render non-SQL literal"; |
308 | } |
5edb4362 |
309 | if ($dq->{literal}) { |
310 | return [ |
311 | $dq->{literal}, @{$dq->{values}||[]} |
312 | ]; |
313 | } elsif ($dq->{parts}) { |
314 | return [ map $self->_render($_), @{$dq->{parts}} ]; |
315 | } else { |
316 | die "Invalid SQL literal - neither 'literal' nor 'parts' found"; |
317 | } |
9c8fc055 |
318 | } |
319 | |
bdb576cb |
320 | sub _render_join { |
321 | my ($self, $dq) = @_; |
322 | my ($left, $right) = @{$dq->{join}}; |
323 | die "No support for ON yet" if $dq->{on}; |
324 | die "No support for LEFT/RIGHT yet" if $dq->{outer}; |
325 | [ $self->_render($left), ',', $self->_render($right) ]; |
326 | } |
327 | |
7f462f86 |
328 | sub _render_where { |
329 | my ($self, $dq) = @_; |
330 | my ($from, $where) = @{$dq}{qw(from where)}; |
331 | [ |
332 | ($from ? $self->_render($from) : ()), |
333 | $self->_format_keyword('WHERE'), |
334 | $self->_render($where) |
335 | ] |
336 | } |
337 | |
338 | sub _render_order { |
339 | my ($self, $dq) = @_; |
340 | my @ret = ( |
341 | $self->_format_keyword('ORDER BY'), |
342 | $self->_render($dq->{by}), |
343 | ($dq->{direction} ? $self->_format_keyword($dq->{direction}) : ()) |
344 | ); |
345 | my $from; |
346 | while ($from = $dq->{from}) { |
347 | last unless $from->{type} eq DQ_ORDER; |
348 | $dq = $from; |
349 | push @ret, ( |
350 | ',', |
351 | $self->_render($dq->{by}), |
352 | ($dq->{direction} ? $self->_format_keyword($dq->{direction}) : ()) |
353 | ); |
354 | } |
355 | unshift @ret, $self->_render($from) if $from; |
356 | \@ret; |
357 | } |
358 | |
515523bc |
359 | 1; |