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( |
7f462f86 |
6 | DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE DQ_JOIN DQ_ALIAS DQ_ORDER |
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 | +{ |
26 | (map +($_ => 'binop'), qw(= > < >= <=) ), |
27 | (map +($_ => 'unop'), (qw(NOT)) ), |
28 | (map +($_ => 'flatten'), qw(AND OR) ), |
29 | } |
30 | } |
31 | |
32 | sub render { |
33 | my $self = shift; |
34 | $self->_flatten_structure($self->_render(@_)) |
35 | } |
36 | |
37 | sub _flatten_structure { |
38 | my ($self, $struct) = @_; |
39 | my @bind; |
bdb576cb |
40 | [ do { |
41 | my @p = map { |
42 | my $r = ref; |
43 | if (!$r) { $_ } |
44 | elsif ($r eq 'ARRAY') { |
45 | my ($sql, @b) = @{$self->_flatten_structure($_)}; |
46 | push @bind, @b; |
47 | $sql; |
48 | } |
49 | elsif ($r eq 'HASH') { push @bind, $_; () } |
50 | else { die "_flatten_structure can't handle ref type $r for $_" } |
51 | } @$struct; |
52 | join '', map { |
53 | ($p[$_], (($p[$_+1]||',') eq ',') ? () : (' ')) |
54 | } 0 .. $#p; |
55 | }, |
56 | @bind |
57 | ]; |
515523bc |
58 | } |
59 | |
9c8fc055 |
60 | # I present this to permit strange people to easily supply a patch to lc() |
61 | # their keywords, as I have heard many desire to do, lest they infect me |
62 | # with whatever malady caused this desire by their continued proximity for |
63 | # want of such a feature. |
64 | |
65 | sub _format_keyword { $_[1] } |
66 | |
515523bc |
67 | sub _render { |
bdb576cb |
68 | $_[0]->${\"_render_${\(lc($_[1]->{type})||'broken')}"}($_[1]); |
69 | } |
70 | |
71 | sub _render_broken { |
72 | my ($self, $dq) = @_; |
73 | require Data::Dumper::Concise; |
74 | die "Broken DQ entry: ".Data::Dumper::Concise::Dumper($dq); |
515523bc |
75 | } |
76 | |
77 | sub _render_identifier { |
78 | die "Unidentified identifier (SQL can no has \$_)" |
79 | unless my @i = @{$_[1]->{elements}}; |
80 | # handle single or paired quote chars |
81 | my ($q1, $q2) = @{$_[0]->{quote_chars}}[0,-1]; |
82 | my $always_quote = $_[0]->{always_quote}; |
83 | my $res_check = $_[0]->{reserved_ident_parts}; |
84 | return [ |
85 | join |
86 | $_[0]->{identifier_sep}||'.', |
87 | map +( |
88 | $_ eq '*' # Yes, this means you can't have a column just called '*'. |
89 | ? $_ # Yes, this is a feature. Go shoot the DBA if he disagrees. |
90 | : ( # reserved are stored uc, quote if non-word |
91 | $always_quote || $res_check->{+uc} || /\W/ |
92 | ? $q1.$_.$q2 |
93 | : $_ |
94 | ) |
95 | ), @i |
96 | ]; |
97 | } |
98 | |
99 | sub _render_value { |
100 | [ '?', $_[1] ]; |
101 | } |
102 | |
12e6eab8 |
103 | sub _operator_type { 'SQL.Naive' } |
104 | |
515523bc |
105 | sub _render_operator { |
106 | my ($self, $dq) = @_; |
107 | my $op = $dq->{operator}; |
12e6eab8 |
108 | unless (exists $op->{$self->_operator_type}) { |
109 | $op->{$self->_operator_type} = $self->_convert_op($dq); |
515523bc |
110 | } |
12e6eab8 |
111 | if (my $op_type = $self->{simple_ops}{my $op_name = $op->{$self->_operator_type}}) { |
515523bc |
112 | return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq); |
113 | } |
12e6eab8 |
114 | die "Couldn't render operator ".$op->{$self->_operator_type}; |
515523bc |
115 | } |
116 | |
117 | sub _handle_op_type_binop { |
118 | my ($self, $op_name, $dq) = @_; |
119 | die "${op_name} registered as binary op but args contain " |
120 | .scalar(@{$dq->{args}})." entries" |
121 | unless @{$dq->{args}} == 2; |
122 | [ |
123 | $self->_render($dq->{args}[0]), |
124 | $op_name, |
125 | $self->_render($dq->{args}[1]), |
126 | ] |
127 | } |
128 | |
129 | sub _handle_op_type_unop { |
130 | my ($self, $op_name, $dq) = @_; |
131 | die "${op_name} registered as unary op but args contain " |
132 | .scalar(@{$dq->{args}})." entries" |
133 | unless @{$dq->{args}} == 1; |
134 | [ |
135 | [ $op_name ], |
136 | $self->_render($dq->{args}[0]), |
137 | ] |
138 | } |
139 | |
140 | sub _handle_op_type_flatten { |
141 | my ($self, $op_name, $dq) = @_; |
142 | my @argq = @{$dq->{args}}; |
143 | my @arg_final; |
144 | while (my $arg = shift @argq) { |
145 | |
146 | unless ($arg->{type} eq DQ_OPERATOR) { |
147 | push @arg_final, $arg; |
148 | next; |
149 | } |
150 | |
151 | my $op = $arg->{operator}; |
12e6eab8 |
152 | unless (exists $op->{$self->_operator_type}) { |
153 | $op->{$self->_operator_type} = $self->_convert_op($arg); |
515523bc |
154 | } |
155 | |
12e6eab8 |
156 | if ($op->{$self->_operator_type} eq $op_name) { |
515523bc |
157 | unshift @argq, @{$arg->{args}}; |
158 | } else { |
159 | push @arg_final, $arg; |
160 | } |
161 | } |
162 | my @sql = ('(', map +($self->_render($_), $op_name), @arg_final); |
163 | $sql[-1] = ')'; # replace final AND or whatever with ) |
164 | \@sql; |
165 | } |
166 | |
167 | sub _convert_op { |
168 | my ($self, $dq) = @_; |
169 | if (my $perl_op = $dq->{'operator'}->{'Perl'}) { |
170 | for ($perl_op) { |
171 | $_ eq '==' and return '='; |
172 | $_ eq 'eq' and return '='; |
173 | $_ eq '!' and return 'NOT'; |
174 | } |
175 | return uc $perl_op; # hope! |
176 | } |
177 | die "Can't convert non-perl op yet"; |
178 | } |
9c8fc055 |
179 | |
180 | sub _render_select { |
181 | my ($self, $dq) = @_; |
182 | die "Empty select list" unless @{$dq->{select}}; |
183 | |
184 | # it is, in fact, completely valid for there to be nothing for us |
185 | # to project from since many databases handle 'SELECT 1;' fine |
186 | |
bdb576cb |
187 | my @select = map [ |
188 | ($_->{type} eq DQ_ALIAS |
7f462f86 |
189 | ? $self->_render_alias($_, $self->_format_keyword('AS')) |
bdb576cb |
190 | : $self->_render($_) |
191 | ), |
192 | ',' |
193 | ], @{$dq->{select}}; |
9c8fc055 |
194 | |
195 | # we put the commas inside the [] for each entry as a hint to the pretty |
bdb576cb |
196 | # printer downstream so now we need to eliminate the comma from the last |
9c8fc055 |
197 | # entry - we know there always is one due to the die guard at the top |
198 | |
199 | pop @{$select[-1]}; |
200 | |
201 | return [ |
202 | $self->_format_keyword('SELECT'), |
203 | \@select, |
204 | # if present this may be a bare FROM, a FROM+WHERE, or a FROM+WHERE+GROUP |
205 | # since we're the SELECT and therefore always come first, we don't care. |
2cf0bb42 |
206 | ($dq->{from} |
207 | ? ($self->_format_keyword('FROM'), @{$self->_render($dq->{from})}) |
208 | : () |
209 | ) |
210 | ]; |
211 | } |
212 | |
213 | sub _render_alias { |
bdb576cb |
214 | my ($self, $dq, $as) = @_; |
2cf0bb42 |
215 | # FROM foo foo -> FROM foo |
216 | # FROM foo.bar bar -> FROM foo.bar |
217 | if ($dq->{alias}{type} eq DQ_IDENTIFIER) { |
218 | if ($dq->{alias}{elements}[-1] eq $dq->{as}) { |
219 | return $self->_render($dq->{alias}); |
220 | } |
221 | } |
222 | return [ |
223 | $self->_render($dq->{alias}), |
bdb576cb |
224 | $as || ' ', |
2cf0bb42 |
225 | $self->_render_identifier({ elements => [ $dq->{as} ] }) |
226 | ]; |
227 | } |
228 | |
229 | sub _render_literal { |
230 | my ($self, $dq) = @_; |
231 | unless ($dq->{subtype} eq 'SQL') { |
232 | die "Can't render non-SQL literal"; |
233 | } |
234 | return [ |
7f462f86 |
235 | $dq->{literal}, @{$dq->{values}||[]} |
9c8fc055 |
236 | ]; |
237 | } |
238 | |
bdb576cb |
239 | sub _render_join { |
240 | my ($self, $dq) = @_; |
241 | my ($left, $right) = @{$dq->{join}}; |
242 | die "No support for ON yet" if $dq->{on}; |
243 | die "No support for LEFT/RIGHT yet" if $dq->{outer}; |
244 | [ $self->_render($left), ',', $self->_render($right) ]; |
245 | } |
246 | |
7f462f86 |
247 | sub _render_where { |
248 | my ($self, $dq) = @_; |
249 | my ($from, $where) = @{$dq}{qw(from where)}; |
250 | [ |
251 | ($from ? $self->_render($from) : ()), |
252 | $self->_format_keyword('WHERE'), |
253 | $self->_render($where) |
254 | ] |
255 | } |
256 | |
257 | sub _render_order { |
258 | my ($self, $dq) = @_; |
259 | my @ret = ( |
260 | $self->_format_keyword('ORDER BY'), |
261 | $self->_render($dq->{by}), |
262 | ($dq->{direction} ? $self->_format_keyword($dq->{direction}) : ()) |
263 | ); |
264 | my $from; |
265 | while ($from = $dq->{from}) { |
266 | last unless $from->{type} eq DQ_ORDER; |
267 | $dq = $from; |
268 | push @ret, ( |
269 | ',', |
270 | $self->_render($dq->{by}), |
271 | ($dq->{direction} ? $self->_format_keyword($dq->{direction}) : ()) |
272 | ); |
273 | } |
274 | unshift @ret, $self->_render($from) if $from; |
275 | \@ret; |
276 | } |
277 | |
515523bc |
278 | 1; |