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