default to unop/binop based on args
[dbsrgits/Data-Query.git] / lib / Data / Query / Renderer / SQL / Naive.pm
CommitLineData
515523bc 1package Data::Query::Renderer::SQL::Naive;
2
3use strictures 1;
4use SQL::ReservedWords;
bdb576cb 5use Data::Query::Constants qw(
7f462f86 6 DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE DQ_JOIN DQ_ALIAS DQ_ORDER
bdb576cb 7);
515523bc 8
9sub new {
10 bless({ %{$_[1]||{}} }, (ref($_[0])||$_[0]))->BUILDALL;
11}
12
13sub 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
24sub _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
36sub render {
37 my $self = shift;
38 $self->_flatten_structure($self->_render(@_))
39}
40
41sub _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
9c8fc055 64# I present this to permit strange people to easily supply a patch to lc()
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.
68
69sub _format_keyword { $_[1] }
70
515523bc 71sub _render {
bdb576cb 72 $_[0]->${\"_render_${\(lc($_[1]->{type})||'broken')}"}($_[1]);
73}
74
75sub _render_broken {
76 my ($self, $dq) = @_;
77 require Data::Dumper::Concise;
78 die "Broken DQ entry: ".Data::Dumper::Concise::Dumper($dq);
515523bc 79}
80
81sub _render_identifier {
82 die "Unidentified identifier (SQL can no has \$_)"
83 unless my @i = @{$_[1]->{elements}};
84 # handle single or paired quote chars
85 my ($q1, $q2) = @{$_[0]->{quote_chars}}[0,-1];
86 my $always_quote = $_[0]->{always_quote};
87 my $res_check = $_[0]->{reserved_ident_parts};
88 return [
89 join
90 $_[0]->{identifier_sep}||'.',
91 map +(
92 $_ eq '*' # Yes, this means you can't have a column just called '*'.
93 ? $_ # Yes, this is a feature. Go shoot the DBA if he disagrees.
94 : ( # reserved are stored uc, quote if non-word
95 $always_quote || $res_check->{+uc} || /\W/
96 ? $q1.$_.$q2
97 : $_
98 )
99 ), @i
100 ];
101}
102
103sub _render_value {
829906e0 104 defined($_[1]->{value})
105 ? [ '?', $_[1] ]
106 : [ 'NULL' ];
515523bc 107}
108
12e6eab8 109sub _operator_type { 'SQL.Naive' }
110
515523bc 111sub _render_operator {
112 my ($self, $dq) = @_;
113 my $op = $dq->{operator};
12e6eab8 114 unless (exists $op->{$self->_operator_type}) {
115 $op->{$self->_operator_type} = $self->_convert_op($dq);
515523bc 116 }
f8343502 117 my $op_name = $op->{$self->_operator_type};
118 if (my $op_type = $self->{simple_ops}{$op_name}) {
515523bc 119 return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq);
f8343502 120 } elsif (my $meth = $self->can("_handle_op_special_${op_name}")) {
121 return $self->$meth($dq);
515523bc 122 }
6e055841 123 if (my $argc = @{$dq->{args}}) {
124 if ($argc == 1) {
125 return $self->_handle_op_type_unop($op_name, $dq);
126 } elsif ($argc == 2) {
127 return $self->_handle_op_type_binop($op_name, $dq);
128 }
129 }
130 die "Unsure how to handle ${op_name}";
515523bc 131}
132
133sub _handle_op_type_binop {
134 my ($self, $op_name, $dq) = @_;
135 die "${op_name} registered as binary op but args contain "
136 .scalar(@{$dq->{args}})." entries"
137 unless @{$dq->{args}} == 2;
138 [
139 $self->_render($dq->{args}[0]),
140 $op_name,
141 $self->_render($dq->{args}[1]),
142 ]
143}
144
145sub _handle_op_type_unop {
146 my ($self, $op_name, $dq) = @_;
147 die "${op_name} registered as unary op but args contain "
148 .scalar(@{$dq->{args}})." entries"
149 unless @{$dq->{args}} == 1;
150 [
f8343502 151 '(',
152 $op_name,
153 $self->_render($dq->{args}[0]),
154 ')',
155 ]
156}
157
158sub _handle_op_type_unop_reverse {
159 my ($self, $op_name, $dq) = @_;
160 die "${op_name} registered as unary op but args contain "
161 .scalar(@{$dq->{args}})." entries"
162 unless @{$dq->{args}} == 1;
163 [
515523bc 164 $self->_render($dq->{args}[0]),
f8343502 165 $op_name,
515523bc 166 ]
167}
168
169sub _handle_op_type_flatten {
170 my ($self, $op_name, $dq) = @_;
171 my @argq = @{$dq->{args}};
172 my @arg_final;
173 while (my $arg = shift @argq) {
174
175 unless ($arg->{type} eq DQ_OPERATOR) {
176 push @arg_final, $arg;
177 next;
178 }
179
180 my $op = $arg->{operator};
12e6eab8 181 unless (exists $op->{$self->_operator_type}) {
182 $op->{$self->_operator_type} = $self->_convert_op($arg);
515523bc 183 }
184
12e6eab8 185 if ($op->{$self->_operator_type} eq $op_name) {
515523bc 186 unshift @argq, @{$arg->{args}};
187 } else {
188 push @arg_final, $arg;
189 }
190 }
191 my @sql = ('(', map +($self->_render($_), $op_name), @arg_final);
192 $sql[-1] = ')'; # replace final AND or whatever with )
193 \@sql;
194}
195
f8343502 196sub _handle_op_type_in {
197 my ($self, $op, $dq) = @_;
198 my ($lhs, @in) = @{$dq->{args}};
199 my @rhs = ('(', map +($self->_render($_), ','), @in);
200 $rhs[-1] = ')';
201 [ $self->_render($lhs), $op, @rhs ];
202}
203
204sub _handle_op_type_between {
205 my ($self, $op_name, $dq) = @_;
206 my ($lhs, $rhs1, $rhs2) = (map $self->_render($_), @{$dq->{args}});
207 [ $lhs, $op_name, $rhs1, 'AND', $rhs2 ];
208}
209
829906e0 210sub _handle_op_type_apply {
211 my ($self, $op_name, $dq) = @_;
212 my ($func, @args) = @{$dq->{args}};
213 die "Function name must be identifier"
214 unless $func->{type} eq DQ_IDENTIFIER;
215 my $ident = $self->_render($func)->[0];
216 [
217 "$ident(",
218 (map $self->_render($_), @args),
219 ')'
220 ]
221}
222
515523bc 223sub _convert_op {
224 my ($self, $dq) = @_;
225 if (my $perl_op = $dq->{'operator'}->{'Perl'}) {
226 for ($perl_op) {
227 $_ eq '==' and return '=';
228 $_ eq 'eq' and return '=';
229 $_ eq '!' and return 'NOT';
230 }
231 return uc $perl_op; # hope!
232 }
233 die "Can't convert non-perl op yet";
234}
9c8fc055 235
236sub _render_select {
237 my ($self, $dq) = @_;
238 die "Empty select list" unless @{$dq->{select}};
239
240 # it is, in fact, completely valid for there to be nothing for us
241 # to project from since many databases handle 'SELECT 1;' fine
242
bdb576cb 243 my @select = map [
244 ($_->{type} eq DQ_ALIAS
7f462f86 245 ? $self->_render_alias($_, $self->_format_keyword('AS'))
bdb576cb 246 : $self->_render($_)
247 ),
248 ','
249 ], @{$dq->{select}};
9c8fc055 250
251 # we put the commas inside the [] for each entry as a hint to the pretty
bdb576cb 252 # printer downstream so now we need to eliminate the comma from the last
9c8fc055 253 # entry - we know there always is one due to the die guard at the top
254
255 pop @{$select[-1]};
256
257 return [
258 $self->_format_keyword('SELECT'),
259 \@select,
260 # if present this may be a bare FROM, a FROM+WHERE, or a FROM+WHERE+GROUP
261 # since we're the SELECT and therefore always come first, we don't care.
2cf0bb42 262 ($dq->{from}
263 ? ($self->_format_keyword('FROM'), @{$self->_render($dq->{from})})
264 : ()
265 )
266 ];
267}
268
269sub _render_alias {
bdb576cb 270 my ($self, $dq, $as) = @_;
2cf0bb42 271 # FROM foo foo -> FROM foo
272 # FROM foo.bar bar -> FROM foo.bar
273 if ($dq->{alias}{type} eq DQ_IDENTIFIER) {
274 if ($dq->{alias}{elements}[-1] eq $dq->{as}) {
275 return $self->_render($dq->{alias});
276 }
277 }
278 return [
279 $self->_render($dq->{alias}),
bdb576cb 280 $as || ' ',
2cf0bb42 281 $self->_render_identifier({ elements => [ $dq->{as} ] })
282 ];
283}
284
285sub _render_literal {
286 my ($self, $dq) = @_;
287 unless ($dq->{subtype} eq 'SQL') {
288 die "Can't render non-SQL literal";
289 }
290 return [
7f462f86 291 $dq->{literal}, @{$dq->{values}||[]}
9c8fc055 292 ];
293}
294
bdb576cb 295sub _render_join {
296 my ($self, $dq) = @_;
297 my ($left, $right) = @{$dq->{join}};
298 die "No support for ON yet" if $dq->{on};
299 die "No support for LEFT/RIGHT yet" if $dq->{outer};
300 [ $self->_render($left), ',', $self->_render($right) ];
301}
302
7f462f86 303sub _render_where {
304 my ($self, $dq) = @_;
305 my ($from, $where) = @{$dq}{qw(from where)};
306 [
307 ($from ? $self->_render($from) : ()),
308 $self->_format_keyword('WHERE'),
309 $self->_render($where)
310 ]
311}
312
313sub _render_order {
314 my ($self, $dq) = @_;
315 my @ret = (
316 $self->_format_keyword('ORDER BY'),
317 $self->_render($dq->{by}),
318 ($dq->{direction} ? $self->_format_keyword($dq->{direction}) : ())
319 );
320 my $from;
321 while ($from = $dq->{from}) {
322 last unless $from->{type} eq DQ_ORDER;
323 $dq = $from;
324 push @ret, (
325 ',',
326 $self->_render($dq->{by}),
327 ($dq->{direction} ? $self->_format_keyword($dq->{direction}) : ())
328 );
329 }
330 unshift @ret, $self->_render($from) if $from;
331 \@ret;
332}
333
515523bc 3341;