Commit | Line | Data |
8f306bb1 |
1 | package SQL::Abstract::Clauses; |
2 | |
3 | use strict; |
4 | use warnings; |
740af2e0 |
5 | use if $] < '5.010', 'MRO::Compat'; |
8f306bb1 |
6 | use mro 'c3'; |
7 | use base 'SQL::Abstract'; |
8 | |
d5f4b9d3 |
9 | BEGIN { *puke = \&SQL::Abstract::puke } |
10 | |
8f306bb1 |
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(@_) }; |
6c39a2f7 |
19 | $self->{render}{select} = sub { shift->_render_statement(@_) }; |
8cad5d13 |
20 | $self->{expand_clause}{"select.$_"} = "_expand_select_clause_$_" |
21 | for @{$self->{clauses_of}{select}}; |
45a145cf |
22 | $self->{clauses_of}{update} = [ qw(target set where returning) ]; |
d5f4b9d3 |
23 | $self->{expand}{update} = sub { shift->_expand_statement(@_) }; |
6c39a2f7 |
24 | $self->{render}{update} = sub { shift->_render_statement(@_) }; |
4c0c4404 |
25 | $self->{expand_clause}{"update.$_"} = "_expand_update_clause_$_" |
26 | for @{$self->{clauses_of}{update}}; |
45a145cf |
27 | $self->{expand_clause}{'update.update'} = '_expand_update_clause_target'; |
28 | $self->{render_clause}{'update.target'} = sub { |
1107714b |
29 | my ($self, undef, $target) = @_; |
57718ef8 |
30 | $self->join_query_parts(' ', $self->format_keyword('update'), $target); |
45a145cf |
31 | }; |
32 | $self->{clauses_of}{delete} = [ qw(target where returning) ]; |
be12624c |
33 | $self->{expand}{delete} = sub { shift->_expand_statement(@_) }; |
6c39a2f7 |
34 | $self->{render}{delete} = sub { shift->_render_statement(@_) }; |
bc637c4f |
35 | $self->{expand_clause}{"delete.$_"} = "_expand_delete_clause_$_" |
36 | for @{$self->{clauses_of}{delete}}; |
45a145cf |
37 | $self->{expand_clause}{"delete.from"} = '_expand_delete_clause_target'; |
38 | $self->{render_clause}{'delete.target'} = sub { |
1107714b |
39 | my ($self, undef, $from) = @_; |
57718ef8 |
40 | $self->join_query_parts(' ', $self->format_keyword('delete from'), $from); |
45a145cf |
41 | }; |
6a47389f |
42 | $self->{clauses_of}{insert} = [ |
bea59460 |
43 | 'target', 'fields', 'from', 'returning' |
6a47389f |
44 | ]; |
5ed4a77e |
45 | $self->{expand}{insert} = sub { shift->_expand_statement(@_) }; |
6c39a2f7 |
46 | $self->{render}{insert} = sub { shift->_render_statement(@_) }; |
45a145cf |
47 | $self->{expand_clause}{'insert.into'} = '_expand_insert_clause_target'; |
48 | $self->{expand_clause}{'insert.target'} = '_expand_insert_clause_target'; |
73f1883a |
49 | $self->{expand_clause}{'insert.fields'} = sub { |
50 | return +{ -row => [ |
b9e452e4 |
51 | $_[0]->_expand_maybe_list_expr($_[2], -ident) |
1107714b |
52 | ] } if ref($_[2]) eq 'ARRAY'; |
53 | return $_[2]; # should maybe still expand somewhat? |
73f1883a |
54 | }; |
89bbac1d |
55 | $self->{expand_clause}{'insert.values'} = '_expand_insert_clause_values'; |
5ed4a77e |
56 | $self->{expand_clause}{'insert.returning'} = sub { |
b9e452e4 |
57 | $_[0]->_expand_maybe_list_expr($_[2], -ident); |
5ed4a77e |
58 | }; |
6a47389f |
59 | $self->{render_clause}{'insert.fields'} = sub { |
1107714b |
60 | return $_[0]->render_aqt($_[2]); |
6a47389f |
61 | }; |
45a145cf |
62 | $self->{render_clause}{'insert.target'} = sub { |
1107714b |
63 | my ($self, undef, $from) = @_; |
57718ef8 |
64 | $self->join_query_parts(' ', $self->format_keyword('insert into'), $from); |
45a145cf |
65 | }; |
bea59460 |
66 | $self->{render_clause}{'insert.from'} = sub { |
1107714b |
67 | return $_[0]->render_aqt($_[2], 1); |
6da32de8 |
68 | }; |
434c40f1 |
69 | $self->{expand}{values} = '_expand_values'; |
70 | $self->{render}{values} = '_render_values'; |
f47b547b |
71 | $self->{expand}{exists} = sub { |
72 | $_[0]->_expand_op(undef, [ exists => $_[2] ]); |
73 | }; |
bfa2e351 |
74 | $self->{render}{convert_where} = sub { |
75 | my $self = shift; |
76 | local $self->{convert_where} = $self->{convert}; |
57718ef8 |
77 | $self->render_aqt($_[1]); |
bfa2e351 |
78 | }; |
8f306bb1 |
79 | return $self; |
80 | } |
81 | |
8cad5d13 |
82 | sub _expand_select_clause_select { |
1107714b |
83 | my ($self, undef, $select) = @_; |
8cad5d13 |
84 | +(select => $self->_expand_maybe_list_expr($select, -ident)); |
85 | } |
86 | |
87 | sub _expand_select_clause_from { |
1107714b |
88 | my ($self, undef, $from) = @_; |
8cad5d13 |
89 | +(from => $self->_expand_maybe_list_expr($from, -ident)); |
90 | } |
91 | |
92 | sub _expand_select_clause_where { |
1107714b |
93 | my ($self, undef, $where) = @_; |
bfa2e351 |
94 | my $exp = $self->expand_expr($where); |
57718ef8 |
95 | +(where => ($self->{convert} ? +{ -convert_where => $exp } : $exp)); |
8cad5d13 |
96 | } |
97 | |
98 | sub _expand_select_clause_order_by { |
1107714b |
99 | my ($self, undef, $order_by) = @_; |
8cad5d13 |
100 | +(order_by => $self->_expand_order_by($order_by)); |
101 | } |
102 | |
45a145cf |
103 | sub _expand_update_clause_target { |
1107714b |
104 | my ($self, undef, $target) = @_; |
0891ae97 |
105 | +(target => $self->_expand_maybe_list_expr($target, -ident)); |
4c0c4404 |
106 | } |
107 | |
108 | sub _expand_update_clause_set { |
1107714b |
109 | return $_[2] if ref($_[2]) eq 'HASH' and ($_[2]->{-op}||[''])->[0] eq ','; |
110 | +(set => $_[0]->_expand_update_set_values($_[1], $_[2])); |
4c0c4404 |
111 | } |
112 | |
113 | sub _expand_update_clause_where { |
1107714b |
114 | +(where => $_[0]->expand_expr($_[2])); |
4c0c4404 |
115 | } |
116 | |
117 | sub _expand_update_clause_returning { |
1107714b |
118 | +(returning => $_[0]->_expand_maybe_list_expr($_[2], -ident)); |
4c0c4404 |
119 | } |
120 | |
45a145cf |
121 | sub _expand_delete_clause_target { |
1107714b |
122 | +(target => $_[0]->_expand_maybe_list_expr($_[2], -ident)); |
bc637c4f |
123 | } |
124 | |
1107714b |
125 | sub _expand_delete_clause_where { +(where => $_[0]->expand_expr($_[2])); } |
bc637c4f |
126 | |
127 | sub _expand_delete_clause_returning { |
1107714b |
128 | +(returning => $_[0]->_expand_maybe_list_expr($_[2], -ident)); |
bc637c4f |
129 | } |
130 | |
8f306bb1 |
131 | sub _expand_statement { |
132 | my ($self, $type, $args) = @_; |
133 | my $ec = $self->{expand_clause}; |
af407e9a |
134 | if ($args->{_}) { |
135 | $args = { %$args }; |
136 | $args->{$type} = delete $args->{_} |
137 | } |
25b45941 |
138 | return +{ "-${type}" => +{ |
95894429 |
139 | map { |
8f306bb1 |
140 | my $val = $args->{$_}; |
141 | if (defined($val) and my $exp = $ec->{"${type}.$_"}) { |
1107714b |
142 | if ((my (@exp) = $self->$exp($_ => $val)) == 1) { |
95894429 |
143 | ($_ => $exp[0]) |
144 | } else { |
145 | @exp |
146 | } |
8f306bb1 |
147 | } else { |
bea59460 |
148 | ($_ => $self->expand_expr($val)) |
8f306bb1 |
149 | } |
95894429 |
150 | } sort keys %$args |
25b45941 |
151 | } }; |
8f306bb1 |
152 | } |
153 | |
154 | sub _render_statement { |
155 | my ($self, $type, $args) = @_; |
156 | my @parts; |
157 | foreach my $clause (@{$self->{clauses_of}{$type}}) { |
158 | next unless my $clause_expr = $args->{$clause}; |
b9d32abc |
159 | my @part = do { |
6a47389f |
160 | if (my $rdr = $self->{render_clause}{"${type}.${clause}"}) { |
1107714b |
161 | $self->$rdr($clause, $clause_expr); |
6a47389f |
162 | } else { |
434c40f1 |
163 | my ($clause_sql, @bind) = $self->render_aqt($clause_expr, 1); |
6a47389f |
164 | my $sql = join ' ', |
165 | $self->_sqlcase(join ' ', split '_', $clause), |
166 | $clause_sql; |
167 | ($sql, @bind); |
168 | } |
169 | }; |
6a47389f |
170 | push @parts, \@part; |
8f306bb1 |
171 | } |
59c7f80e |
172 | my ($sql, @bind) = $self->join_query_parts(' ', @parts); |
434c40f1 |
173 | return ( |
174 | (our $Render_Top_Level ? $sql : '('.$sql.')'), |
175 | @bind |
176 | ); |
177 | } |
178 | |
179 | sub render_aqt { |
180 | my ($self, $aqt, $top_level) = @_; |
181 | local our $Render_Top_Level = $top_level; |
182 | return $self->next::method($aqt); |
183 | } |
184 | |
185 | sub render_statement { |
186 | my ($self, $expr, $default_scalar_to) = @_; |
187 | my ($sql, @bind) = $self->render_aqt( |
188 | $self->expand_expr($expr, $default_scalar_to), 1 |
189 | ); |
190 | return (wantarray ? ($sql, @bind) : $sql); |
8f306bb1 |
191 | } |
192 | |
b96fbdc0 |
193 | sub select { |
194 | my ($self, @args) = @_; |
73f1883a |
195 | |
434c40f1 |
196 | return $self->render_statement({ -select => $_[1] }) if ref($_[1]) eq 'HASH'; |
73f1883a |
197 | |
b96fbdc0 |
198 | my %clauses; |
199 | @clauses{qw(from select where order_by)} = @args; |
0c3c4c23 |
200 | |
b96fbdc0 |
201 | # This oddity is to literalify since historically SQLA doesn't quote |
0c3c4c23 |
202 | # a single identifier argument, so we convert it into a literal |
203 | |
91d37de5 |
204 | $clauses{select} = { -literal => [ $clauses{select}||'*' ] } |
205 | unless ref($clauses{select}); |
206 | |
434c40f1 |
207 | return $self->render_statement({ -select => \%clauses }); |
b96fbdc0 |
208 | } |
209 | |
d5f4b9d3 |
210 | sub update { |
211 | my ($self, $table, $set, $where, $options) = @_; |
73f1883a |
212 | |
434c40f1 |
213 | return $self->render_statement({ -update => $_[1] }) if ref($_[1]) eq 'HASH'; |
73f1883a |
214 | |
d5f4b9d3 |
215 | my %clauses; |
45a145cf |
216 | @clauses{qw(target set where)} = ($table, $set, $where); |
d5f4b9d3 |
217 | puke "Unsupported data type specified to \$sql->update" |
218 | unless ref($clauses{set}) eq 'HASH'; |
219 | @clauses{keys %$options} = values %$options; |
434c40f1 |
220 | return $self->render_statement({ -update => \%clauses }); |
d5f4b9d3 |
221 | } |
222 | |
be12624c |
223 | sub delete { |
224 | my ($self, $table, $where, $options) = @_; |
73f1883a |
225 | |
434c40f1 |
226 | return $self->render_statement({ -delete => $_[1] }) if ref($_[1]) eq 'HASH'; |
73f1883a |
227 | |
45a145cf |
228 | my %clauses = (target => $table, where => $where, %{$options||{}}); |
434c40f1 |
229 | return $self->render_statement({ -delete => \%clauses }); |
be12624c |
230 | } |
231 | |
5ed4a77e |
232 | sub insert { |
233 | my ($self, $table, $data, $options) = @_; |
73f1883a |
234 | |
434c40f1 |
235 | return $self->render_statement({ -insert => $_[1] }) if ref($_[1]) eq 'HASH'; |
73f1883a |
236 | |
45a145cf |
237 | my %clauses = (target => $table, values => $data, %{$options||{}}); |
434c40f1 |
238 | return $self->render_statement({ -insert => \%clauses }); |
5ed4a77e |
239 | } |
240 | |
45a145cf |
241 | sub _expand_insert_clause_target { |
1107714b |
242 | +(target => $_[0]->_expand_maybe_list_expr($_[2], -ident)); |
45a145cf |
243 | } |
244 | |
89bbac1d |
245 | sub _expand_insert_clause_values { |
1107714b |
246 | my ($self, undef, $data) = @_; |
6da32de8 |
247 | if (ref($data) eq 'HASH' and (keys(%$data))[0] =~ /^-/) { |
248 | return $self->expand_expr($data); |
249 | } |
e5d02bc7 |
250 | return $data if ref($data) eq 'HASH' and $data->{-row}; |
89bbac1d |
251 | my ($f_aqt, $v_aqt) = $self->_expand_insert_values($data); |
bea59460 |
252 | return (from => { -values => $v_aqt }, ($f_aqt ? (fields => $f_aqt) : ())); |
89bbac1d |
253 | } |
254 | |
434c40f1 |
255 | sub _expand_values { |
256 | my ($self, undef, $values) = @_; |
257 | return { -values => [ |
258 | map +( |
259 | ref($_) eq 'HASH' |
260 | ? $self->expand_expr($_) |
261 | : +{ -row => [ map $self->expand_expr($_), @$_ ] } |
262 | ), ref($values) eq 'ARRAY' ? @$values : $values |
263 | ] }; |
264 | } |
265 | |
266 | sub _render_values { |
6c39a2f7 |
267 | my ($self, undef, $values) = @_; |
57718ef8 |
268 | my $inner = [ |
269 | $self->join_query_parts(' ', |
270 | $self->format_keyword('values'), |
271 | [ $self->join_query_parts(', ', |
272 | ref($values) eq 'ARRAY' ? @$values : $values |
273 | ) ], |
274 | ), |
275 | ]; |
276 | return $self->join_query_parts('', |
277 | (our $Render_Top_Level ? $inner : ('(', $inner, ')')) |
434c40f1 |
278 | ); |
279 | } |
280 | |
8637f869 |
281 | sub _ext_rw { |
282 | my ($self, $name, $key, $value) = @_; |
f7a20100 |
283 | return $self->{$name}{$key} unless @_ > 3; |
8637f869 |
284 | $self->{$name}{$key} = $value; |
285 | return $self; |
286 | } |
287 | |
52a5554b |
288 | BEGIN { |
289 | foreach my $type (qw( |
f7a20100 |
290 | expand op_expand render op_render clause_expand clause_render |
52a5554b |
291 | )) { |
95ab9342 |
292 | my $name = join '_', reverse split '_', $type; |
71c1b4d5 |
293 | my $singular = "${type}er"; |
95ab9342 |
294 | eval qq{sub ${singular} { shift->_ext_rw($name => \@_) }; 1 } |
295 | or die "Method builder failed for ${singular}: $@"; |
296 | eval qq{sub wrap_${singular} { |
297 | my (\$self, \$key, \$builder) = \@_; |
298 | my \$orig = \$self->_ext_rw('${name}', \$key); |
299 | \$self->_ext_rw( |
300 | '${name}', \$key, |
301 | \$builder->(\$orig, '${name}', \$key) |
302 | ); |
303 | }; 1 } or die "Method builder failed for wrap_${singular}: $@"; |
71c1b4d5 |
304 | eval qq{sub ${singular}s { |
305 | my (\$self, \@args) = \@_; |
306 | while (my (\$this_key, \$this_value) = splice(\@args, 0, 2)) { |
95ab9342 |
307 | \$self->{${name}}{\$this_key} = \$this_value; |
71c1b4d5 |
308 | } |
309 | return \$self; |
310 | }; 1 } or die "Method builder failed for ${singular}s: $@"; |
95ab9342 |
311 | eval qq{sub ${singular}_list { sort keys %{\$_[0]->{\$name}} }; 1; } |
312 | or die "Method builder failed for ${singular}_list: $@"; |
52a5554b |
313 | } |
314 | } |
8637f869 |
315 | |
78bbc7c8 |
316 | sub statement_list { sort keys %{$_[0]->{clauses_of}} } |
08a26ed6 |
317 | |
8637f869 |
318 | sub clauses_of { |
319 | my ($self, $of, @clauses) = @_; |
320 | unless (@clauses) { |
321 | return @{$self->{clauses_of}{$of}||[]}; |
322 | } |
e6b86bee |
323 | if (ref($clauses[0]) eq 'CODE') { |
324 | @clauses = $self->${\($clauses[0])}(@{$self->{clauses_of}{$of}||[]}); |
325 | } |
8637f869 |
326 | $self->{clauses_of}{$of} = \@clauses; |
327 | return $self; |
328 | } |
329 | |
330 | sub clone { |
331 | my ($self) = @_; |
332 | bless( |
333 | { |
334 | (map +($_ => ( |
335 | ref($self->{$_}) eq 'HASH' |
336 | ? { %{$self->{$_}} } |
337 | : $self->{$_} |
338 | )), keys %$self), |
339 | }, |
340 | ref($self) |
341 | ); |
342 | } |
343 | |
8f306bb1 |
344 | 1; |