working RowNumberOver
[dbsrgits/Data-Query.git] / lib / Data / Query / Renderer / SQL / Naive.pm
1 package Data::Query::Renderer::SQL::Naive;
2
3 use strictures 1;
4
5 sub intersperse { my $i = shift; my @i = map +($_, $i), @_; pop @i; @i }
6
7 use SQL::ReservedWords;
8 use Data::Query::ExprHelpers;
9
10 use Moo;
11
12 has reserved_ident_parts => (
13   is => 'ro', default => sub {
14     our $_DEFAULT_RESERVED ||= { map +($_ => 1), SQL::ReservedWords->words }
15   }
16 );
17
18 has quote_chars => (is => 'ro', default => sub { [''] });
19
20 has identifier_sep => (is => 'ro', default => sub { '.' });
21
22 has simple_ops => (is => 'ro', builder => '_default_simple_ops');
23
24 has lc_keywords => (is => 'ro', default => sub { 0 });
25
26 has always_quote => (is => 'ro', default => sub { 0 });
27
28 has collapse_aliases => (is => 'ro', default => sub { 1 });
29
30 sub _default_simple_ops {
31   +{
32     (map +($_ => 'binop'), qw(= > < >= <= != LIKE), 'NOT LIKE' ),
33     (map +($_ => 'unop'), qw(NOT) ),
34     (map +($_ => 'unop_reverse'), ('IS NULL', 'IS NOT NULL')),
35     (map +($_ => 'flatten'), qw(AND OR) ),
36     (map +($_ => 'in'), ('IN', 'NOT IN')),
37     (map +($_ => 'between'), ('BETWEEN', 'NOT BETWEEN')),
38     (apply => 'apply'),
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;
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   ];
68 }
69
70 # I presented this to permit strange people to easily supply a patch to lc()
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.
74 #
75 # Then I realised that SQL::Abstract compatibility work required it.
76 #
77 # FEH.
78
79 sub _format_keyword { $_[0]->lc_keywords ? lc($_[1]) : $_[1] }
80
81 sub _render {
82   die "Expected hashref, got $_[1]" unless ref($_[1]) eq 'HASH';
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);
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
96   my ($q1, $q2) = @{$_[0]->quote_chars}[0,-1];
97   my $always_quote = $_[0]->always_quote;
98   my $res_check = $_[0]->reserved_ident_parts;
99   return [
100     join
101       $_[0]->identifier_sep,
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
106               ($always_quote and $q1) || $res_check->{+uc} || /\W/
107                 ? $q1.$_.$q2
108                 : $_
109             )
110       ), @i
111   ];
112 }
113
114 sub _render_value {
115   [ '?', $_[1] ]
116 }
117
118 sub _operator_type { 'SQL.Naive' }
119
120 sub _render_operator {
121   my ($self, $dq) = @_;
122   my $op = $dq->{operator};
123   unless (exists $op->{$self->_operator_type}) {
124     $op->{$self->_operator_type} = $self->_convert_op($dq);
125   }
126   my $op_name = $op->{$self->_operator_type};
127   if (my $op_type = $self->simple_ops->{$op_name}) {
128     return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq);
129   } elsif (my $meth = $self->can("_handle_op_special_${op_name}")) {
130     return $self->$meth($dq);
131   }
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}";
140 }
141
142 sub _maybe_parenthesise {
143   my ($self, $dq) = @_;
144   for ($dq) {
145     return is_Select() || is_Slice()
146       ? [ '(', $self->_render($dq), ')' ]
147       : $self->_render($dq);
148   }
149 }
150
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   [
157     $self->_maybe_parenthesise($dq->{args}[0]),
158     $op_name,
159     $self->_maybe_parenthesise($dq->{args}[1]),
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   [
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   [
182     $self->_render($dq->{args}[0]),
183     $op_name,
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
193     unless (is_Operator($arg)) {
194       push @arg_final, $arg;
195       next;
196     }
197
198     my $op = $arg->{operator};
199     unless (exists $op->{$self->_operator_type}) {
200       $op->{$self->_operator_type} = $self->_convert_op($arg);
201     }
202   
203     if ($op->{$self->_operator_type} eq $op_name) {
204       unshift @argq, @{$arg->{args}};
205     } else {
206       push @arg_final, $arg;
207     }
208   }
209   [ '(',
210       intersperse(
211         $self->_format_keyword($op_name),
212         map $self->_maybe_parenthesise($_), @arg_final
213       ),
214     ')'
215   ];
216 }
217
218 sub _handle_op_type_in {
219   my ($self, $op, $dq) = @_;
220   my ($lhs, @in) = @{$dq->{args}};
221   [ $self->_render($lhs),
222     $op,
223     '(',
224       intersperse(',', map $self->_render($_), @in),
225     ')'
226   ];
227 }
228
229 sub _handle_op_type_between {
230   my ($self, $op_name, $dq) = @_;
231   my @args = @{$dq->{args}};
232   if (@args == 3) {
233     my ($lhs, $rhs1, $rhs2) = (map $self->_maybe_parenthesise($_), @args);
234     [ '(', $lhs, $op_name, $rhs1, 'AND', $rhs2, ')' ];
235   } elsif (@args == 2 and is_Literal $args[1]->{type}) {
236     my ($lhs, $rhs) = (map $self->_render($_), @args);
237     [ '(', $lhs, $op_name, $rhs, ')' ];
238   } else {
239     die "Invalid args for between: ${\scalar @args} given";
240   }
241 }
242
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"
247     unless is_Identifier $func;
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   };
256   [
257     "$ident(",
258       intersperse(',', map $self->_maybe_parenthesise($_), @args),
259     ')'
260   ]
261 }
262
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 }
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
283   my @select = intersperse(',',
284     map +(is_Alias()
285            ? $self->_render_alias($_, $self->_format_keyword('AS'))
286            : $self->_render($_)), @{$dq->{select}}
287   );
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.
294     ($dq->{from}
295        ? ($self->_format_keyword('FROM'), @{$self->_render($dq->{from})})
296        : ()
297     ),
298   ];
299 }
300
301 sub _render_alias {
302   my ($self, $dq, $as) = @_;
303   # FROM foo foo -> FROM foo
304   # FROM foo.bar bar -> FROM foo.bar
305   if ($self->collapse_aliases) {
306     if (is_Identifier(my $from = $dq->{from})) {
307       if ($from->{elements}[-1] eq $dq->{to}) {
308         return $self->_render($from);
309       }
310     }
311   }
312   return [
313     $self->_maybe_parenthesise($dq->{from}),
314     $as || ' ',
315     $self->_render_identifier({ elements => [ $dq->{to} ] })
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   }
324   if (defined($dq->{literal})) {
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   }
333 }
334
335 sub _render_join {
336   my ($self, $dq) = @_;
337   my ($left, $right) = @{$dq}{qw(left right)};
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   };
347   my $rhs = $self->_render($right);
348   [
349     $self->_render($left), $join,
350     (is_Join($right) ? ('(', $rhs, ')') : $rhs),
351     ($dq->{on}
352       ? ($self->_format_keyword('ON'), $self->_render($dq->{on}))
353       : ())
354   ];
355 }
356
357 sub _render_where {
358   my ($self, $dq) = @_;
359   my ($from, $where) = @{$dq}{qw(from where)};
360   my $keyword = (is_Group($from) ? 'HAVING' : 'WHERE');
361   [
362     ($from ? $self->_render($from) : ()),
363     $self->_format_keyword($keyword),
364     $self->_render($where)
365   ]
366 }
367
368 sub _render_order {
369   my ($self, $dq) = @_;
370   my @ret = (
371     $self->_format_keyword('ORDER BY'),
372     $self->_render($dq->{by}),
373     ($dq->{reverse}
374       ? $self->_format_keyword('DESC')
375       : ())
376   );
377   my $from;
378   while ($from = $dq->{from}) {
379     last unless is_Order $from;
380     $dq = $from;
381     push @ret, (
382       ',',
383       $self->_render($dq->{by}),
384       ($dq->{reverse}
385         ? $self->_format_keyword('DESC')
386         : ())
387     );
388   }
389   unshift @ret, $self->_render($from) if $from;
390   \@ret;
391 }
392
393 sub _render_group {
394   my ($self, $dq) = @_;
395   # this could also squash like order does. but I dunno whether that should
396   # move somewhere else just yet.
397   my @ret = (
398     ($dq->{from} ? $self->_render($dq->{from}) : ()),
399     (@{$dq->{by}}
400       ? (
401           $self->_format_keyword('GROUP BY'),
402           intersperse(',', map $self->_render($_), @{$dq->{by}})
403          )
404       : ())
405   );
406   \@ret;
407 }
408
409 sub _render_delete {
410   my ($self, $dq) = @_;
411   my ($target, $where) = @{$dq}{qw(target where)};
412   [ $self->_format_keyword('DELETE FROM'), 
413     $self->_render($target),
414     ($where
415       ? ($self->_format_keyword('WHERE'), $self->_render($where))
416       : ())
417   ];
418 }
419
420 sub _render_update {
421   my ($self, $dq) = @_;
422   my ($target, $set, $where) = @{$dq}{qw(target set where)};
423   unless ($set) {
424     die "Must have set key - names+value keys not yet tested";
425     my ($names, $value) = @{$dq}{qw(names value)};
426     die "Must have names and value or set" unless $names and $value;
427     die "names and value must be same size" unless @$names == @$value;
428     $set = [ map [ $names->[$_], $value->[$_] ], 0..$#$names ];
429   }
430   my @rendered_set = intersperse(
431     ',', map [ intersperse('=', map $self->_render($_), @$_) ], @{$set}
432   );
433   [ $self->_format_keyword('UPDATE'),
434     $self->_render($target),
435     $self->_format_keyword('SET'),
436     @rendered_set,
437     ($where
438       ? ($self->_format_keyword('WHERE'), $self->_render($where))
439       : ())
440   ];
441 }
442
443 sub _render_insert {
444   my ($self, $dq) = @_;
445   my ($target, $names, $values, $returning)
446     = @{$dq}{qw(target names values returning)};
447   unless ($values) {
448     die "Must have values key - sets key not yet implemented";
449   }
450   [ $self->_format_keyword('INSERT INTO'),
451     $self->_render($target),
452     ($names
453       ? ('(', intersperse(',', map $self->_render($_), @$names), ')')
454       : ()),
455     $self->_format_keyword('VALUES'),
456     intersperse(',',
457       map [ '(', intersperse(',', map $self->_render($_), @$_), ')' ],
458         @$values
459     ),
460     ($returning
461       ? ($self->_format_keyword('RETURNING'),
462          intersperse(',', map $self->_render($_), @$returning))
463       : ()),
464   ];
465 }
466
467 1;