Commit | Line | Data |
515523bc |
1 | package Data::Query::Renderer::SQL::Naive; |
2 | |
3 | use strictures 1; |
87867dad |
4 | |
515523bc |
5 | use SQL::ReservedWords; |
6b45ffe4 |
6 | use Data::Query::ExprHelpers; |
515523bc |
7 | |
8b4289c8 |
8 | use Moo; |
515523bc |
9 | |
8b4289c8 |
10 | has reserved_ident_parts => ( |
11 | is => 'ro', default => sub { |
12 | our $_DEFAULT_RESERVED ||= { map +($_ => 1), SQL::ReservedWords->words } |
13 | } |
14 | ); |
15 | |
16 | has quote_chars => (is => 'ro', default => sub { [''] }); |
17 | |
4cea30e6 |
18 | has identifier_sep => (is => 'ro', default => sub { '.' }); |
19 | |
8b4289c8 |
20 | has simple_ops => (is => 'ro', builder => '_default_simple_ops'); |
515523bc |
21 | |
4cea30e6 |
22 | has lc_keywords => (is => 'ro', default => sub { 0 }); |
23 | |
24 | has always_quote => (is => 'ro', default => sub { 0 }); |
25 | |
07b0f7e0 |
26 | has collapse_aliases => (is => 'ro', default => sub { 1 }); |
27 | |
515523bc |
28 | sub _default_simple_ops { |
29 | +{ |
f8343502 |
30 | (map +($_ => 'binop'), qw(= > < >= <= != LIKE), 'NOT LIKE' ), |
31 | (map +($_ => 'unop'), qw(NOT) ), |
32 | (map +($_ => 'unop_reverse'), ('IS NULL', 'IS NOT NULL')), |
515523bc |
33 | (map +($_ => 'flatten'), qw(AND OR) ), |
f8343502 |
34 | (map +($_ => 'in'), ('IN', 'NOT IN')), |
829906e0 |
35 | (map +($_ => 'between'), ('BETWEEN', 'NOT BETWEEN')), |
36 | (apply => 'apply'), |
515523bc |
37 | } |
38 | } |
39 | |
40 | sub render { |
41 | my $self = shift; |
42 | $self->_flatten_structure($self->_render(@_)) |
43 | } |
44 | |
45 | sub _flatten_structure { |
46 | my ($self, $struct) = @_; |
47 | my @bind; |
bdb576cb |
48 | [ do { |
49 | my @p = map { |
50 | my $r = ref; |
51 | if (!$r) { $_ } |
52 | elsif ($r eq 'ARRAY') { |
53 | my ($sql, @b) = @{$self->_flatten_structure($_)}; |
54 | push @bind, @b; |
55 | $sql; |
56 | } |
57 | elsif ($r eq 'HASH') { push @bind, $_; () } |
58 | else { die "_flatten_structure can't handle ref type $r for $_" } |
59 | } @$struct; |
60 | join '', map { |
61 | ($p[$_], (($p[$_+1]||',') eq ',') ? () : (' ')) |
62 | } 0 .. $#p; |
63 | }, |
64 | @bind |
65 | ]; |
515523bc |
66 | } |
67 | |
04d30ecb |
68 | # I presented this to permit strange people to easily supply a patch to lc() |
9c8fc055 |
69 | # their keywords, as I have heard many desire to do, lest they infect me |
70 | # with whatever malady caused this desire by their continued proximity for |
71 | # want of such a feature. |
04d30ecb |
72 | # |
73 | # Then I realised that SQL::Abstract compatibility work required it. |
74 | # |
75 | # FEH. |
9c8fc055 |
76 | |
4cea30e6 |
77 | sub _format_keyword { $_[0]->lc_keywords ? lc($_[1]) : $_[1] } |
9c8fc055 |
78 | |
515523bc |
79 | sub _render { |
22a08f9b |
80 | unless (ref($_[1]) eq 'HASH') { |
81 | die "Expected hashref, got ".(defined($_[1])?$_[1]:'undef'); |
82 | } |
bdb576cb |
83 | $_[0]->${\"_render_${\(lc($_[1]->{type})||'broken')}"}($_[1]); |
84 | } |
85 | |
86 | sub _render_broken { |
87 | my ($self, $dq) = @_; |
88 | require Data::Dumper::Concise; |
89 | die "Broken DQ entry: ".Data::Dumper::Concise::Dumper($dq); |
515523bc |
90 | } |
91 | |
92 | sub _render_identifier { |
93 | die "Unidentified identifier (SQL can no has \$_)" |
94 | unless my @i = @{$_[1]->{elements}}; |
95 | # handle single or paired quote chars |
8b4289c8 |
96 | my ($q1, $q2) = @{$_[0]->quote_chars}[0,-1]; |
4cea30e6 |
97 | my $always_quote = $_[0]->always_quote; |
8b4289c8 |
98 | my $res_check = $_[0]->reserved_ident_parts; |
515523bc |
99 | return [ |
100 | join |
4cea30e6 |
101 | $_[0]->identifier_sep, |
515523bc |
102 | map +( |
103 | $_ eq '*' # Yes, this means you can't have a column just called '*'. |
104 | ? $_ # Yes, this is a feature. Go shoot the DBA if he disagrees. |
105 | : ( # reserved are stored uc, quote if non-word |
713f29aa |
106 | ($always_quote and $q1) || $res_check->{+uc} || /\W/ |
515523bc |
107 | ? $q1.$_.$q2 |
108 | : $_ |
109 | ) |
110 | ), @i |
111 | ]; |
112 | } |
113 | |
114 | sub _render_value { |
a5c0a2d5 |
115 | [ '?', $_[1] ] |
515523bc |
116 | } |
117 | |
12e6eab8 |
118 | sub _operator_type { 'SQL.Naive' } |
119 | |
515523bc |
120 | sub _render_operator { |
121 | my ($self, $dq) = @_; |
122 | my $op = $dq->{operator}; |
12e6eab8 |
123 | unless (exists $op->{$self->_operator_type}) { |
124 | $op->{$self->_operator_type} = $self->_convert_op($dq); |
515523bc |
125 | } |
f8343502 |
126 | my $op_name = $op->{$self->_operator_type}; |
d17f527f |
127 | if (my $op_type = $self->simple_ops->{$op_name}) { |
515523bc |
128 | return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq); |
f8343502 |
129 | } elsif (my $meth = $self->can("_handle_op_special_${op_name}")) { |
130 | return $self->$meth($dq); |
515523bc |
131 | } |
6e055841 |
132 | if (my $argc = @{$dq->{args}}) { |
133 | if ($argc == 1) { |
134 | return $self->_handle_op_type_unop($op_name, $dq); |
135 | } elsif ($argc == 2) { |
136 | return $self->_handle_op_type_binop($op_name, $dq); |
137 | } |
138 | } |
139 | die "Unsure how to handle ${op_name}"; |
515523bc |
140 | } |
141 | |
410dc8ab |
142 | sub _maybe_parenthesise { |
143 | my ($self, $dq) = @_; |
6b45ffe4 |
144 | for ($dq) { |
5a058623 |
145 | return is_Select() || is_Group() || is_Slice() || is_Having() |
410dc8ab |
146 | ? [ '(', $self->_render($dq), ')' ] |
6b45ffe4 |
147 | : $self->_render($dq); |
148 | } |
410dc8ab |
149 | } |
150 | |
515523bc |
151 | sub _handle_op_type_binop { |
152 | my ($self, $op_name, $dq) = @_; |
153 | die "${op_name} registered as binary op but args contain " |
154 | .scalar(@{$dq->{args}})." entries" |
155 | unless @{$dq->{args}} == 2; |
156 | [ |
410dc8ab |
157 | $self->_maybe_parenthesise($dq->{args}[0]), |
515523bc |
158 | $op_name, |
410dc8ab |
159 | $self->_maybe_parenthesise($dq->{args}[1]), |
515523bc |
160 | ] |
161 | } |
162 | |
163 | sub _handle_op_type_unop { |
164 | my ($self, $op_name, $dq) = @_; |
165 | die "${op_name} registered as unary op but args contain " |
166 | .scalar(@{$dq->{args}})." entries" |
167 | unless @{$dq->{args}} == 1; |
168 | [ |
f8343502 |
169 | '(', |
170 | $op_name, |
171 | $self->_render($dq->{args}[0]), |
172 | ')', |
173 | ] |
174 | } |
175 | |
176 | sub _handle_op_type_unop_reverse { |
177 | my ($self, $op_name, $dq) = @_; |
178 | die "${op_name} registered as unary op but args contain " |
179 | .scalar(@{$dq->{args}})." entries" |
180 | unless @{$dq->{args}} == 1; |
181 | [ |
515523bc |
182 | $self->_render($dq->{args}[0]), |
f8343502 |
183 | $op_name, |
515523bc |
184 | ] |
185 | } |
186 | |
187 | sub _handle_op_type_flatten { |
188 | my ($self, $op_name, $dq) = @_; |
189 | my @argq = @{$dq->{args}}; |
190 | my @arg_final; |
191 | while (my $arg = shift @argq) { |
192 | |
6b45ffe4 |
193 | unless (is_Operator($arg)) { |
515523bc |
194 | push @arg_final, $arg; |
195 | next; |
196 | } |
197 | |
198 | my $op = $arg->{operator}; |
12e6eab8 |
199 | unless (exists $op->{$self->_operator_type}) { |
200 | $op->{$self->_operator_type} = $self->_convert_op($arg); |
515523bc |
201 | } |
202 | |
12e6eab8 |
203 | if ($op->{$self->_operator_type} eq $op_name) { |
515523bc |
204 | unshift @argq, @{$arg->{args}}; |
205 | } else { |
206 | push @arg_final, $arg; |
207 | } |
208 | } |
9d8243ac |
209 | [ '(', |
210 | intersperse( |
211 | $self->_format_keyword($op_name), |
410dc8ab |
212 | map $self->_maybe_parenthesise($_), @arg_final |
9d8243ac |
213 | ), |
214 | ')' |
215 | ]; |
515523bc |
216 | } |
217 | |
f8343502 |
218 | sub _handle_op_type_in { |
219 | my ($self, $op, $dq) = @_; |
220 | my ($lhs, @in) = @{$dq->{args}}; |
9d8243ac |
221 | [ $self->_render($lhs), |
222 | $op, |
223 | '(', |
224 | intersperse(',', map $self->_render($_), @in), |
225 | ')' |
226 | ]; |
f8343502 |
227 | } |
228 | |
229 | sub _handle_op_type_between { |
230 | my ($self, $op_name, $dq) = @_; |
f3f803da |
231 | my @args = @{$dq->{args}}; |
232 | if (@args == 3) { |
410dc8ab |
233 | my ($lhs, $rhs1, $rhs2) = (map $self->_maybe_parenthesise($_), @args); |
839687b2 |
234 | [ '(', $lhs, $op_name, $rhs1, 'AND', $rhs2, ')' ]; |
e0fb8686 |
235 | } elsif (@args == 2 and is_Literal $args[1]) { |
f3f803da |
236 | my ($lhs, $rhs) = (map $self->_render($_), @args); |
839687b2 |
237 | [ '(', $lhs, $op_name, $rhs, ')' ]; |
f3f803da |
238 | } else { |
239 | die "Invalid args for between: ${\scalar @args} given"; |
240 | } |
f8343502 |
241 | } |
242 | |
829906e0 |
243 | sub _handle_op_type_apply { |
244 | my ($self, $op_name, $dq) = @_; |
245 | my ($func, @args) = @{$dq->{args}}; |
246 | die "Function name must be identifier" |
6b45ffe4 |
247 | unless is_Identifier $func; |
54a46537 |
248 | my $ident = do { |
249 | # The problem we have here is that built-ins can't be quoted, generally. |
250 | # I rather wonder if things like MAX(...) need to -not- be handled as |
251 | # an apply and instead of something else, maybe a parenop type - but |
252 | # as an explicitly Naive renderer this seems like a reasonable answer. |
253 | local @{$self}{qw(reserved_ident_parts always_quote)}; |
254 | $self->_render_identifier($func)->[0]; |
255 | }; |
829906e0 |
256 | [ |
257 | "$ident(", |
410dc8ab |
258 | intersperse(',', map $self->_maybe_parenthesise($_), @args), |
829906e0 |
259 | ')' |
260 | ] |
261 | } |
262 | |
515523bc |
263 | sub _convert_op { |
264 | my ($self, $dq) = @_; |
265 | if (my $perl_op = $dq->{'operator'}->{'Perl'}) { |
266 | for ($perl_op) { |
267 | $_ eq '==' and return '='; |
268 | $_ eq 'eq' and return '='; |
269 | $_ eq '!' and return 'NOT'; |
270 | } |
271 | return uc $perl_op; # hope! |
272 | } |
273 | die "Can't convert non-perl op yet"; |
274 | } |
9c8fc055 |
275 | |
276 | sub _render_select { |
277 | my ($self, $dq) = @_; |
278 | die "Empty select list" unless @{$dq->{select}}; |
279 | |
280 | # it is, in fact, completely valid for there to be nothing for us |
281 | # to project from since many databases handle 'SELECT 1;' fine |
282 | |
9d8243ac |
283 | my @select = intersperse(',', |
6b45ffe4 |
284 | map +(is_Alias() |
9d8243ac |
285 | ? $self->_render_alias($_, $self->_format_keyword('AS')) |
286 | : $self->_render($_)), @{$dq->{select}} |
287 | ); |
9c8fc055 |
288 | |
289 | return [ |
290 | $self->_format_keyword('SELECT'), |
291 | \@select, |
292 | # if present this may be a bare FROM, a FROM+WHERE, or a FROM+WHERE+GROUP |
293 | # since we're the SELECT and therefore always come first, we don't care. |
2cf0bb42 |
294 | ($dq->{from} |
295 | ? ($self->_format_keyword('FROM'), @{$self->_render($dq->{from})}) |
296 | : () |
0446ca9c |
297 | ), |
2cf0bb42 |
298 | ]; |
299 | } |
300 | |
301 | sub _render_alias { |
bdb576cb |
302 | my ($self, $dq, $as) = @_; |
2cf0bb42 |
303 | # FROM foo foo -> FROM foo |
304 | # FROM foo.bar bar -> FROM foo.bar |
07b0f7e0 |
305 | if ($self->collapse_aliases) { |
6b45ffe4 |
306 | if (is_Identifier(my $from = $dq->{from})) { |
307 | if ($from->{elements}[-1] eq $dq->{to}) { |
308 | return $self->_render($from); |
07b0f7e0 |
309 | } |
2cf0bb42 |
310 | } |
311 | } |
6b45ffe4 |
312 | return [ |
410dc8ab |
313 | $self->_maybe_parenthesise($dq->{from}), |
4e0c6139 |
314 | $as || '', |
07b0f7e0 |
315 | $self->_render_identifier({ elements => [ $dq->{to} ] }) |
2cf0bb42 |
316 | ]; |
317 | } |
318 | |
319 | sub _render_literal { |
320 | my ($self, $dq) = @_; |
321 | unless ($dq->{subtype} eq 'SQL') { |
322 | die "Can't render non-SQL literal"; |
323 | } |
e8428681 |
324 | if (defined($dq->{literal})) { |
5edb4362 |
325 | return [ |
326 | $dq->{literal}, @{$dq->{values}||[]} |
327 | ]; |
328 | } elsif ($dq->{parts}) { |
329 | return [ map $self->_render($_), @{$dq->{parts}} ]; |
330 | } else { |
331 | die "Invalid SQL literal - neither 'literal' nor 'parts' found"; |
332 | } |
9c8fc055 |
333 | } |
334 | |
bdb576cb |
335 | sub _render_join { |
336 | my ($self, $dq) = @_; |
07b0f7e0 |
337 | my ($left, $right) = @{$dq}{qw(left right)}; |
2f95eef1 |
338 | my $join = do { |
339 | if ($dq->{outer}) { |
340 | $self->_format_keyword(uc($dq->{outer}).' JOIN'); |
341 | } elsif ($dq->{on}) { |
342 | $self->_format_keyword('JOIN'); |
343 | } else { |
344 | ',' |
345 | } |
346 | }; |
f16c57e9 |
347 | my $rhs = $self->_render($right); |
2f95eef1 |
348 | [ |
f16c57e9 |
349 | $self->_render($left), $join, |
6b45ffe4 |
350 | (is_Join($right) ? ('(', $rhs, ')') : $rhs), |
2f95eef1 |
351 | ($dq->{on} |
352 | ? ($self->_format_keyword('ON'), $self->_render($dq->{on})) |
353 | : ()) |
354 | ]; |
bdb576cb |
355 | } |
356 | |
7f462f86 |
357 | sub _render_where { |
358 | my ($self, $dq) = @_; |
359 | my ($from, $where) = @{$dq}{qw(from where)}; |
a4ccc49e |
360 | while (is_Where $from) { |
361 | $where = Operator({ 'SQL.Naive' => 'and' }, [ $where, $from->{where} ]); |
362 | $from = $from->{from}; |
363 | } |
6b45ffe4 |
364 | my $keyword = (is_Group($from) ? 'HAVING' : 'WHERE'); |
7f462f86 |
365 | [ |
366 | ($from ? $self->_render($from) : ()), |
a1042388 |
367 | $self->_format_keyword($keyword), |
7f462f86 |
368 | $self->_render($where) |
369 | ] |
370 | } |
371 | |
e3335558 |
372 | sub _order_chunk { |
7f462f86 |
373 | my ($self, $dq) = @_; |
e3335558 |
374 | return +( |
7f462f86 |
375 | $self->_render($dq->{by}), |
b6b6113e |
376 | ($dq->{reverse} |
377 | ? $self->_format_keyword('DESC') |
e3335558 |
378 | : ()), |
379 | ($dq->{nulls} |
380 | ? $self->_format_keyword('NULLS '.('', qw(FIRST LAST))[$dq->{nulls}]) |
381 | : ()), |
382 | ); |
383 | } |
384 | |
385 | sub _render_order { |
386 | my ($self, $dq) = @_; |
387 | my @ret = ( |
388 | $self->_format_keyword('ORDER BY'), |
389 | $self->_order_chunk($dq), |
7f462f86 |
390 | ); |
391 | my $from; |
392 | while ($from = $dq->{from}) { |
6b45ffe4 |
393 | last unless is_Order $from; |
7f462f86 |
394 | $dq = $from; |
395 | push @ret, ( |
396 | ',', |
e3335558 |
397 | $self->_order_chunk($dq), |
7f462f86 |
398 | ); |
399 | } |
400 | unshift @ret, $self->_render($from) if $from; |
401 | \@ret; |
402 | } |
403 | |
a1042388 |
404 | sub _render_group { |
405 | my ($self, $dq) = @_; |
406 | # this could also squash like order does. but I dunno whether that should |
407 | # move somewhere else just yet. |
408 | my @ret = ( |
409 | ($dq->{from} ? $self->_render($dq->{from}) : ()), |
a010d224 |
410 | (@{$dq->{by}} |
411 | ? ( |
412 | $self->_format_keyword('GROUP BY'), |
413 | intersperse(',', map $self->_render($_), @{$dq->{by}}) |
414 | ) |
415 | : ()) |
a1042388 |
416 | ); |
417 | \@ret; |
418 | } |
419 | |
dc657ce1 |
420 | sub _render_delete { |
421 | my ($self, $dq) = @_; |
87867dad |
422 | my ($target, $where) = @{$dq}{qw(target where)}; |
423 | [ $self->_format_keyword('DELETE FROM'), |
424 | $self->_render($target), |
425 | ($where |
426 | ? ($self->_format_keyword('WHERE'), $self->_render($where)) |
427 | : ()) |
428 | ]; |
429 | } |
430 | |
431 | sub _render_update { |
432 | my ($self, $dq) = @_; |
433 | my ($target, $set, $where) = @{$dq}{qw(target set where)}; |
a5c0a2d5 |
434 | unless ($set) { |
435 | die "Must have set key - names+value keys not yet tested"; |
436 | my ($names, $value) = @{$dq}{qw(names value)}; |
437 | die "Must have names and value or set" unless $names and $value; |
438 | die "names and value must be same size" unless @$names == @$value; |
439 | $set = [ map [ $names->[$_], $value->[$_] ], 0..$#$names ]; |
440 | } |
87867dad |
441 | my @rendered_set = intersperse( |
442 | ',', map [ intersperse('=', map $self->_render($_), @$_) ], @{$set} |
443 | ); |
444 | [ $self->_format_keyword('UPDATE'), |
445 | $self->_render($target), |
446 | $self->_format_keyword('SET'), |
447 | @rendered_set, |
448 | ($where |
449 | ? ($self->_format_keyword('WHERE'), $self->_render($where)) |
450 | : ()) |
451 | ]; |
dc657ce1 |
452 | } |
453 | |
a5c0a2d5 |
454 | sub _render_insert { |
455 | my ($self, $dq) = @_; |
456 | my ($target, $names, $values, $returning) |
457 | = @{$dq}{qw(target names values returning)}; |
458 | unless ($values) { |
459 | die "Must have values key - sets key not yet implemented"; |
460 | } |
461 | [ $self->_format_keyword('INSERT INTO'), |
462 | $self->_render($target), |
463 | ($names |
464 | ? ('(', intersperse(',', map $self->_render($_), @$names), ')') |
465 | : ()), |
466 | $self->_format_keyword('VALUES'), |
467 | intersperse(',', |
468 | map [ '(', intersperse(',', map $self->_render($_), @$_), ')' ], |
469 | @$values |
470 | ), |
471 | ($returning |
472 | ? ($self->_format_keyword('RETURNING'), |
473 | intersperse(',', map $self->_render($_), @$returning)) |
474 | : ()), |
475 | ]; |
476 | } |
477 | |
515523bc |
478 | 1; |