Commit | Line | Data |
bbe638af |
1 | package SQL::Abstract::Clauses; |
2 | |
3 | use strict; |
4 | use warnings; |
ccb7f3d6 |
5 | use if $] < '5.010', 'MRO::Compat'; |
bbe638af |
6 | use mro 'c3'; |
7 | use base 'SQL::Abstract'; |
8 | |
1bcd361f |
9 | BEGIN { *puke = \&SQL::Abstract::puke } |
10 | |
bbe638af |
11 | sub new { |
12 | shift->next::method(@_)->register_defaults |
13 | } |
14 | |
15 | sub register_defaults { |
16 | my ($self) = @_; |
17 | $self->{clauses_of}{select} = [ qw(select from where order_by) ]; |
18 | $self->{expand}{select} = sub { shift->_expand_statement(@_) }; |
a01911a2 |
19 | $self->{render}{select} = sub { shift->_render_statement(@_) }; |
df0f5af9 |
20 | $self->{expand_clause}{"select.$_"} = "_expand_select_clause_$_" |
21 | for @{$self->{clauses_of}{select}}; |
46158aa8 |
22 | $self->{clauses_of}{update} = [ qw(target set where returning) ]; |
1bcd361f |
23 | $self->{expand}{update} = sub { shift->_expand_statement(@_) }; |
a01911a2 |
24 | $self->{render}{update} = sub { shift->_render_statement(@_) }; |
889fdd38 |
25 | $self->{expand_clause}{"update.$_"} = "_expand_update_clause_$_" |
26 | for @{$self->{clauses_of}{update}}; |
46158aa8 |
27 | $self->{expand_clause}{'update.update'} = '_expand_update_clause_target'; |
28 | $self->{render_clause}{'update.target'} = sub { |
fe8b493f |
29 | my ($self, undef, $target) = @_; |
e7f248c4 |
30 | $self->join_query_parts(' ', $self->format_keyword('update'), $target); |
46158aa8 |
31 | }; |
32 | $self->{clauses_of}{delete} = [ qw(target where returning) ]; |
77e8c03d |
33 | $self->{expand}{delete} = sub { shift->_expand_statement(@_) }; |
a01911a2 |
34 | $self->{render}{delete} = sub { shift->_render_statement(@_) }; |
44296b4e |
35 | $self->{expand_clause}{"delete.$_"} = "_expand_delete_clause_$_" |
36 | for @{$self->{clauses_of}{delete}}; |
46158aa8 |
37 | $self->{expand_clause}{"delete.from"} = '_expand_delete_clause_target'; |
38 | $self->{render_clause}{'delete.target'} = sub { |
fe8b493f |
39 | my ($self, undef, $from) = @_; |
e7f248c4 |
40 | $self->join_query_parts(' ', $self->format_keyword('delete from'), $from); |
46158aa8 |
41 | }; |
2b057b28 |
42 | $self->{clauses_of}{insert} = [ |
93253a11 |
43 | 'target', 'fields', 'from', 'returning' |
2b057b28 |
44 | ]; |
39544e0e |
45 | $self->{expand}{insert} = sub { shift->_expand_statement(@_) }; |
a01911a2 |
46 | $self->{render}{insert} = sub { shift->_render_statement(@_) }; |
ddbe2793 |
47 | $self->{expand_clause}{"insert.$_"} = "_expand_insert_clause_$_" |
48 | for @{$self->{clauses_of}{insert}}; |
46158aa8 |
49 | $self->{expand_clause}{'insert.into'} = '_expand_insert_clause_target'; |
ddbe2793 |
50 | $self->{expand_clause}{'insert.values'} = '_expand_insert_clause_from'; |
2b057b28 |
51 | $self->{render_clause}{'insert.fields'} = sub { |
7c532574 |
52 | return $_[0]->render_aqt($_[2]); |
2b057b28 |
53 | }; |
46158aa8 |
54 | $self->{render_clause}{'insert.target'} = sub { |
fe8b493f |
55 | my ($self, undef, $from) = @_; |
e7f248c4 |
56 | $self->join_query_parts(' ', $self->format_keyword('insert into'), $from); |
46158aa8 |
57 | }; |
93253a11 |
58 | $self->{render_clause}{'insert.from'} = sub { |
7c532574 |
59 | return $_[0]->render_aqt($_[2], 1); |
f8d50921 |
60 | }; |
01222ad2 |
61 | $self->{expand}{values} = '_expand_values'; |
62 | $self->{render}{values} = '_render_values'; |
7250aa13 |
63 | $self->{expand}{exists} = sub { |
64 | $_[0]->_expand_op(undef, [ exists => $_[2] ]); |
65 | }; |
bbe638af |
66 | return $self; |
67 | } |
68 | |
df0f5af9 |
69 | sub _expand_select_clause_select { |
fe8b493f |
70 | my ($self, undef, $select) = @_; |
df0f5af9 |
71 | +(select => $self->_expand_maybe_list_expr($select, -ident)); |
72 | } |
73 | |
74 | sub _expand_select_clause_from { |
fe8b493f |
75 | my ($self, undef, $from) = @_; |
df0f5af9 |
76 | +(from => $self->_expand_maybe_list_expr($from, -ident)); |
77 | } |
78 | |
79 | sub _expand_select_clause_where { |
fe8b493f |
80 | my ($self, undef, $where) = @_; |
67e082b8 |
81 | |
91c490fa |
82 | my $sqla = do { |
83 | if (my $conv = $self->{convert}) { |
84 | my $_wrap = sub { |
85 | my $orig = shift; |
86 | sub { |
87 | my $self = shift; |
88 | +{ -func => [ |
89 | $conv, |
90 | $self->$orig(@_) |
91 | ] }; |
92 | }; |
93 | }; |
94 | $self->clone |
95 | ->wrap_expanders(map +($_ => $_wrap), qw(ident value bind)) |
96 | ->wrap_op_expanders(map +($_ => $_wrap), qw(ident value bind)) |
97 | ->wrap_expander(func => sub { |
98 | my $orig = shift; |
99 | sub { |
100 | my ($self, $type, $thing) = @_; |
101 | if (ref($thing) eq 'ARRAY' and $thing->[0] eq $conv |
102 | and @$thing == 2 and ref($thing->[1]) eq 'HASH' |
103 | and ( |
104 | $thing->[1]{-ident} |
105 | or $thing->[1]{-value} |
106 | or $thing->[1]{-bind}) |
107 | ) { |
108 | return { -func => $thing }; # already went through our expander |
109 | } |
110 | return $self->$orig($type, $thing); |
111 | } |
112 | }); |
113 | } else { |
114 | $self; |
67e082b8 |
115 | } |
91c490fa |
116 | }; |
67e082b8 |
117 | |
91c490fa |
118 | return +(where => $sqla->expand_expr($where)); |
df0f5af9 |
119 | } |
120 | |
121 | sub _expand_select_clause_order_by { |
fe8b493f |
122 | my ($self, undef, $order_by) = @_; |
df0f5af9 |
123 | +(order_by => $self->_expand_order_by($order_by)); |
124 | } |
125 | |
46158aa8 |
126 | sub _expand_update_clause_target { |
fe8b493f |
127 | my ($self, undef, $target) = @_; |
e0eb8d26 |
128 | +(target => $self->_expand_maybe_list_expr($target, -ident)); |
889fdd38 |
129 | } |
130 | |
131 | sub _expand_update_clause_set { |
fe8b493f |
132 | return $_[2] if ref($_[2]) eq 'HASH' and ($_[2]->{-op}||[''])->[0] eq ','; |
133 | +(set => $_[0]->_expand_update_set_values($_[1], $_[2])); |
889fdd38 |
134 | } |
135 | |
136 | sub _expand_update_clause_where { |
fe8b493f |
137 | +(where => $_[0]->expand_expr($_[2])); |
889fdd38 |
138 | } |
139 | |
140 | sub _expand_update_clause_returning { |
fe8b493f |
141 | +(returning => $_[0]->_expand_maybe_list_expr($_[2], -ident)); |
889fdd38 |
142 | } |
143 | |
46158aa8 |
144 | sub _expand_delete_clause_target { |
fe8b493f |
145 | +(target => $_[0]->_expand_maybe_list_expr($_[2], -ident)); |
44296b4e |
146 | } |
147 | |
fe8b493f |
148 | sub _expand_delete_clause_where { +(where => $_[0]->expand_expr($_[2])); } |
44296b4e |
149 | |
150 | sub _expand_delete_clause_returning { |
fe8b493f |
151 | +(returning => $_[0]->_expand_maybe_list_expr($_[2], -ident)); |
44296b4e |
152 | } |
153 | |
bbe638af |
154 | sub _expand_statement { |
155 | my ($self, $type, $args) = @_; |
156 | my $ec = $self->{expand_clause}; |
f9f1fdcd |
157 | if ($args->{_}) { |
158 | $args = { %$args }; |
159 | $args->{$type} = delete $args->{_} |
160 | } |
27d61b67 |
161 | return +{ "-${type}" => +{ |
c79c67d7 |
162 | map { |
bbe638af |
163 | my $val = $args->{$_}; |
164 | if (defined($val) and my $exp = $ec->{"${type}.$_"}) { |
fe8b493f |
165 | if ((my (@exp) = $self->$exp($_ => $val)) == 1) { |
c79c67d7 |
166 | ($_ => $exp[0]) |
167 | } else { |
168 | @exp |
169 | } |
bbe638af |
170 | } else { |
93253a11 |
171 | ($_ => $self->expand_expr($val)) |
bbe638af |
172 | } |
c79c67d7 |
173 | } sort keys %$args |
27d61b67 |
174 | } }; |
bbe638af |
175 | } |
176 | |
177 | sub _render_statement { |
178 | my ($self, $type, $args) = @_; |
179 | my @parts; |
180 | foreach my $clause (@{$self->{clauses_of}{$type}}) { |
181 | next unless my $clause_expr = $args->{$clause}; |
7c532574 |
182 | my $part = do { |
2b057b28 |
183 | if (my $rdr = $self->{render_clause}{"${type}.${clause}"}) { |
fe8b493f |
184 | $self->$rdr($clause, $clause_expr); |
2b057b28 |
185 | } else { |
7c532574 |
186 | $self->join_query_parts(' ', |
187 | $self->format_keyword($clause), |
188 | $self->render_aqt($clause_expr, 1) |
189 | ); |
2b057b28 |
190 | } |
191 | }; |
7c532574 |
192 | push @parts, $part; |
bbe638af |
193 | } |
531d5231 |
194 | my $q = $self->join_query_parts(' ', @parts); |
195 | return $self->join_query_parts('', |
196 | (our $Render_Top_Level ? $q : ('(', $q, ')')) |
197 | ); |
01222ad2 |
198 | } |
199 | |
200 | sub render_aqt { |
201 | my ($self, $aqt, $top_level) = @_; |
202 | local our $Render_Top_Level = $top_level; |
203 | return $self->next::method($aqt); |
204 | } |
205 | |
206 | sub render_statement { |
207 | my ($self, $expr, $default_scalar_to) = @_; |
7c532574 |
208 | $self->render_aqt( |
01222ad2 |
209 | $self->expand_expr($expr, $default_scalar_to), 1 |
7c532574 |
210 | ); |
bbe638af |
211 | } |
212 | |
81b270e7 |
213 | sub select { |
214 | my ($self, @args) = @_; |
7958f5c6 |
215 | |
7c532574 |
216 | my $stmt = do { |
217 | if (ref(my $sel = $args[0]) eq 'HASH') { |
3f312d2e |
218 | $sel |
7c532574 |
219 | } else { |
220 | my %clauses; |
221 | @clauses{qw(from select where order_by)} = @args; |
7958f5c6 |
222 | |
7c532574 |
223 | # This oddity is to literalify since historically SQLA doesn't quote |
224 | # a single identifier argument, so we convert it into a literal |
8e6988ce |
225 | |
7c532574 |
226 | $clauses{select} = { -literal => [ $clauses{select}||'*' ] } |
227 | unless ref($clauses{select}); |
228 | \%clauses; |
229 | } |
230 | }; |
4ee74413 |
231 | |
7c532574 |
232 | my $rendered = $self->render_statement({ -select => $stmt }); |
233 | return wantarray ? @$rendered : $rendered->[0]; |
81b270e7 |
234 | } |
235 | |
1bcd361f |
236 | sub update { |
237 | my ($self, $table, $set, $where, $options) = @_; |
7958f5c6 |
238 | |
3f312d2e |
239 | my $stmt = do { |
240 | if (ref($table) eq 'HASH') { |
241 | $table |
242 | } else { |
243 | my %clauses; |
244 | @clauses{qw(target set where)} = ($table, $set, $where); |
245 | puke "Unsupported data type specified to \$sql->update" |
246 | unless ref($clauses{set}) eq 'HASH'; |
247 | @clauses{keys %$options} = values %$options; |
248 | \%clauses; |
249 | } |
250 | }; |
251 | my $rendered = $self->render_statement({ -update => $stmt }); |
252 | return wantarray ? @$rendered : $rendered->[0]; |
1bcd361f |
253 | } |
254 | |
77e8c03d |
255 | sub delete { |
256 | my ($self, $table, $where, $options) = @_; |
7958f5c6 |
257 | |
3f312d2e |
258 | my $stmt = do { |
259 | if (ref($table) eq 'HASH') { |
260 | $table; |
261 | } else { |
262 | my %clauses = (target => $table, where => $where, %{$options||{}}); |
263 | \%clauses; |
264 | } |
265 | }; |
266 | my $rendered = $self->render_statement({ -delete => $stmt }); |
267 | return wantarray ? @$rendered : $rendered->[0]; |
77e8c03d |
268 | } |
269 | |
39544e0e |
270 | sub insert { |
271 | my ($self, $table, $data, $options) = @_; |
7958f5c6 |
272 | |
3f312d2e |
273 | my $stmt = do { |
274 | if (ref($table) eq 'HASH') { |
275 | $table; |
276 | } else { |
277 | my %clauses = (target => $table, values => $data, %{$options||{}}); |
278 | \%clauses; |
279 | } |
280 | }; |
281 | my $rendered = $self->render_statement({ -insert => $stmt }); |
282 | return wantarray ? @$rendered : $rendered->[0]; |
39544e0e |
283 | } |
284 | |
46158aa8 |
285 | sub _expand_insert_clause_target { |
fe8b493f |
286 | +(target => $_[0]->_expand_maybe_list_expr($_[2], -ident)); |
46158aa8 |
287 | } |
288 | |
ddbe2793 |
289 | sub _expand_insert_clause_fields { |
290 | return +{ -row => [ |
291 | $_[0]->_expand_maybe_list_expr($_[2], -ident) |
292 | ] } if ref($_[2]) eq 'ARRAY'; |
293 | return $_[2]; # should maybe still expand somewhat? |
294 | } |
295 | |
296 | sub _expand_insert_clause_from { |
fe8b493f |
297 | my ($self, undef, $data) = @_; |
f8d50921 |
298 | if (ref($data) eq 'HASH' and (keys(%$data))[0] =~ /^-/) { |
299 | return $self->expand_expr($data); |
300 | } |
e5feec9f |
301 | return $data if ref($data) eq 'HASH' and $data->{-row}; |
f33d93b5 |
302 | my ($f_aqt, $v_aqt) = $self->_expand_insert_values($data); |
67e082b8 |
303 | return ( |
304 | from => { -values => [ $v_aqt ] }, |
305 | ($f_aqt ? (fields => $f_aqt) : ()), |
306 | ); |
f33d93b5 |
307 | } |
308 | |
ddbe2793 |
309 | sub _expand_insert_clause_returning { |
310 | +(returning => $_[0]->_expand_maybe_list_expr($_[2], -ident)); |
311 | } |
312 | |
01222ad2 |
313 | sub _expand_values { |
314 | my ($self, undef, $values) = @_; |
315 | return { -values => [ |
316 | map +( |
317 | ref($_) eq 'HASH' |
318 | ? $self->expand_expr($_) |
319 | : +{ -row => [ map $self->expand_expr($_), @$_ ] } |
320 | ), ref($values) eq 'ARRAY' ? @$values : $values |
321 | ] }; |
322 | } |
323 | |
324 | sub _render_values { |
a01911a2 |
325 | my ($self, undef, $values) = @_; |
3f312d2e |
326 | my $inner = $self->join_query_parts(' ', |
327 | $self->format_keyword('values'), |
328 | $self->join_query_parts(', ', |
329 | ref($values) eq 'ARRAY' ? @$values : $values |
e7f248c4 |
330 | ), |
3f312d2e |
331 | ); |
e7f248c4 |
332 | return $self->join_query_parts('', |
333 | (our $Render_Top_Level ? $inner : ('(', $inner, ')')) |
01222ad2 |
334 | ); |
335 | } |
336 | |
34570093 |
337 | sub _ext_rw { |
338 | my ($self, $name, $key, $value) = @_; |
2b0b3d43 |
339 | return $self->{$name}{$key} unless @_ > 3; |
34570093 |
340 | $self->{$name}{$key} = $value; |
341 | return $self; |
342 | } |
343 | |
d390df44 |
344 | BEGIN { |
345 | foreach my $type (qw( |
2b0b3d43 |
346 | expand op_expand render op_render clause_expand clause_render |
d390df44 |
347 | )) { |
3f9899e5 |
348 | my $name = join '_', reverse split '_', $type; |
58ebc7fa |
349 | my $singular = "${type}er"; |
3f9899e5 |
350 | eval qq{sub ${singular} { shift->_ext_rw($name => \@_) }; 1 } |
351 | or die "Method builder failed for ${singular}: $@"; |
352 | eval qq{sub wrap_${singular} { |
353 | my (\$self, \$key, \$builder) = \@_; |
354 | my \$orig = \$self->_ext_rw('${name}', \$key); |
355 | \$self->_ext_rw( |
356 | '${name}', \$key, |
357 | \$builder->(\$orig, '${name}', \$key) |
358 | ); |
359 | }; 1 } or die "Method builder failed for wrap_${singular}: $@"; |
58ebc7fa |
360 | eval qq{sub ${singular}s { |
361 | my (\$self, \@args) = \@_; |
362 | while (my (\$this_key, \$this_value) = splice(\@args, 0, 2)) { |
4dd6472f |
363 | \$self->_ext_rw('${name}', \$this_key, \$this_value); |
58ebc7fa |
364 | } |
365 | return \$self; |
366 | }; 1 } or die "Method builder failed for ${singular}s: $@"; |
4dd6472f |
367 | eval qq{sub wrap_${singular}s { |
368 | my (\$self, \@args) = \@_; |
369 | while (my (\$this_key, \$this_builder) = splice(\@args, 0, 2)) { |
370 | my \$orig = \$self->_ext_rw('${name}', \$this_key); |
371 | \$self->_ext_rw( |
372 | '${name}', \$this_key, |
373 | \$this_builder->(\$orig, '${name}', \$this_key), |
374 | ); |
375 | } |
376 | return \$self; |
377 | }; 1 } or die "Method builder failed for wrap_${singular}s: $@"; |
3f9899e5 |
378 | eval qq{sub ${singular}_list { sort keys %{\$_[0]->{\$name}} }; 1; } |
379 | or die "Method builder failed for ${singular}_list: $@"; |
d390df44 |
380 | } |
381 | } |
34570093 |
382 | |
a17df223 |
383 | sub statement_list { sort keys %{$_[0]->{clauses_of}} } |
54a2a1e5 |
384 | |
34570093 |
385 | sub clauses_of { |
386 | my ($self, $of, @clauses) = @_; |
387 | unless (@clauses) { |
388 | return @{$self->{clauses_of}{$of}||[]}; |
389 | } |
ee706e89 |
390 | if (ref($clauses[0]) eq 'CODE') { |
391 | @clauses = $self->${\($clauses[0])}(@{$self->{clauses_of}{$of}||[]}); |
392 | } |
34570093 |
393 | $self->{clauses_of}{$of} = \@clauses; |
394 | return $self; |
395 | } |
396 | |
397 | sub clone { |
398 | my ($self) = @_; |
399 | bless( |
400 | { |
401 | (map +($_ => ( |
402 | ref($self->{$_}) eq 'HASH' |
403 | ? { %{$self->{$_}} } |
404 | : $self->{$_} |
405 | )), keys %$self), |
406 | }, |
407 | ref($self) |
408 | ); |
409 | } |
410 | |
bbe638af |
411 | 1; |