consolidate other things
[dbsrgits/SQL-Abstract.git] / lib / SQL / Abstract / ExtraClauses.pm
CommitLineData
1ff9018c 1package SQL::Abstract::ExtraClauses;
2
df5d0507 3use Moo;
4
5has sqla => (
6 is => 'ro', init_arg => undef,
7 handles => [ qw(
1601bb47 8 expand_expr expand_maybe_list_expr render_aqt join_query_parts
df5d0507 9 ) ],
10);
1ff9018c 11
df5d0507 12sub cb {
c671eba6 13 my ($self, $method, @args) = @_;
14 return sub {
15 local $self->{sqla} = shift;
16 $self->$method(@args, @_)
17 };
df5d0507 18}
19
ec49a2e1 20sub register {
d37f2f17 21 my ($self, @pairs) = @_;
ec49a2e1 22 my $sqla = $self->sqla;
d37f2f17 23 while (my ($method, $cases) = splice(@pairs, 0, 2)) {
24 my @cases = @$cases;
25 while (my ($name, $case) = splice(@cases, 0, 2)) {
26 $sqla->$method($name, $self->cb($case));
27 }
ec49a2e1 28 }
29 return $self;
30}
31
df5d0507 32sub apply_to {
33 my ($self, $sqla) = @_;
34 $self = $self->new unless ref($self);
ec49a2e1 35 local $self->{sqla} = $sqla;
36 $self->register_extensions($sqla);
37}
38
39sub register_extensions {
40 my ($self, $sqla) = @_;
ad078c71 41 my @clauses = $sqla->clauses_of('select');
2b0b3d43 42 my @before_setop;
43 CLAUSE: foreach my $idx (0..$#clauses) {
44 if ($clauses[$idx] eq 'order_by') {
45 @before_setop = @clauses[0..$idx-1];
46 splice(@clauses, $idx, 0, qw(setop group_by having));
47 last CLAUSE;
48 }
49 }
50 die "Huh?" unless @before_setop;
ad078c71 51 $sqla->clauses_of(select => 'with', @clauses);
ec49a2e1 52 $self->register(
d37f2f17 53 clause_expanders => [
ec49a2e1 54 'select.group_by'
55 => sub { $_[0]->expand_maybe_list_expr($_[2], -ident) },
56 'select.having'
57 => sub { $_[0]->expand_expr($_[2]) },
d37f2f17 58 ],
e67751dd 59 (map +(
60 "${_}er" => [
61 do {
62 my $x = $_;
63 (map +($_ => "_${x}_${_}"), qw(join from_list alias))
64 }
65 ]
66 ), qw(expand render)),
67 binop_expander => [ as => '_expand_op_as' ],
68 renderer => [ as => '_render_as' ],
69 expander => [ cast => '_expand_cast' ],
47662caa 70 );
58ebc7fa 71
ad078c71 72 $sqla->clauses_of(update => sub {
ee706e89 73 my ($self, @clauses) = @_;
74 splice(@clauses, 2, 0, 'from');
75 @clauses;
76 });
77
ad078c71 78 $sqla->clauses_of(delete => sub {
ee706e89 79 my ($self, @clauses) = @_;
80 splice(@clauses, 1, 0, 'using');
81 @clauses;
82 });
83
ad078c71 84 $sqla->clause_expanders(
805c64f1 85 'update.from' => $self->cb('_expand_from_list'),
9a20a32d 86 'delete.using' => $self->cb('_expand_from_list'),
df5d0507 87 'insert.rowvalues' => $self->cb(sub {
fe8b493f 88 +(from => $_[0]->expand_expr({ -values => $_[2] }));
df5d0507 89 }),
90 'insert.select' => $self->cb(sub {
fe8b493f 91 +(from => $_[0]->expand_expr({ -select => $_[2] }));
df5d0507 92 }),
58ebc7fa 93 );
26994fdd 94
2b0b3d43 95 # set ops
ad078c71 96 $sqla->wrap_expander(select => sub {
c671eba6 97 $self->cb('_expand_select', $_[0], \@before_setop);
3f9899e5 98 });
2b0b3d43 99
e2db8228 100 $sqla->clause_renderer(
101 'select.setop' => $self->cb(sub { $_[0]->render_aqt($_[2]); })
102 );
2b0b3d43 103
51046d0e 104 foreach my $setop (qw(union intersect except)) {
105 $sqla->expander($setop => $self->cb('_expand_setop'));
106 $sqla->renderer($setop => $self->cb('_render_setop'));
107 }
260e0f29 108
41086177 109 my $setop_expander = $self->cb('_expand_clause_setop');
f61bfd7b 110
ad078c71 111 $sqla->clause_expanders(
f61bfd7b 112 map +($_ => $setop_expander),
113 map "select.${_}",
114 map +($_, "${_}_all", "${_}_distinct"),
115 qw(union intersect except)
116 );
d175037f 117
2f4717ad 118 my $w_exp = $self->cb('_expand_with');
119 my $w_rdr = $self->cb('_render_with');
120 $sqla->clause_expander('select.with' => $w_exp);
121 $sqla->clause_expander('select.with_recursive' => $w_exp);
122 $sqla->clause_renderer('select.with' => $w_rdr);
123
a97ecd95 124 foreach my $stmt (qw(insert update delete)) {
ad078c71 125 $sqla->clauses_of($stmt => 'with', $sqla->clauses_of($stmt));
2f4717ad 126 $sqla->clause_expander("${stmt}.$_" => $w_exp)
a97ecd95 127 for qw(with with_recursive);
2f4717ad 128 $sqla->clause_renderer("${stmt}.with" => $w_rdr);
a97ecd95 129 }
2f4717ad 130
ad078c71 131 $sqla->clause_expanders(
805c64f1 132 "select.from", $self->cb('_expand_from_list'),
df5d0507 133 "update.target", $self->cb('_expand_update_clause_target'),
134 "update.update", $self->cb('_expand_update_clause_target'),
135 );
2b0b3d43 136
ad078c71 137 return $sqla;
1ff9018c 138}
139
c671eba6 140sub _expand_select {
093442c8 141 my ($self, $orig, $before_setop, @args) = @_;
142 my $exp = $self->sqla->$orig(@args);
c671eba6 143 return $exp unless my $setop = (my $sel = $exp->{-select})->{setop};
144 if (my @keys = grep $sel->{$_}, @$before_setop) {
145 my %inner; @inner{@keys} = delete @{$sel}{@keys};
146 unshift @{(values(%$setop))[0]{queries}},
147 { -select => \%inner };
148 }
149 return $exp;
150}
151
7741b7ad 152sub _expand_from_list {
153 my ($self, undef, $args) = @_;
154 if (ref($args) eq 'HASH') {
38e67490 155 return $args if $args->{-from_list};
7741b7ad 156 return { -from_list => [ $self->expand_expr($args) ] };
157 }
158 my @list;
86a6ebf4 159 my @args = ref($args) eq 'ARRAY' ? @$args : ($args);
7741b7ad 160 while (my $entry = shift @args) {
b99e9a14 161 if (!ref($entry) and $entry =~ /^-(.*)/) {
162 if ($1 eq 'as') {
163 $list[-1] = $self->expand_expr({ -as => [
164 $list[-1], map +(ref($_) eq 'ARRAY' ? @$_ : $_), shift(@args)
165 ]});
166 next;
167 }
7741b7ad 168 $entry = { $entry => shift @args };
169 }
170 my $aqt = $self->expand_expr($entry, -ident);
171 if ($aqt->{-join} and not $aqt->{-join}{from}) {
172 $aqt->{-join}{from} = pop @list;
173 }
174 push @list, $aqt;
175 }
176 return { -from_list => \@list };
177}
178
179sub _expand_join {
180 my ($self, undef, $args) = @_;
181 my %proto = (
182 ref($args) eq 'HASH'
183 ? %$args
184 : (to => $args->[0], @{$args}[1..$#$args])
185 );
b99e9a14 186 if (my $as = delete $proto{as}) {
984db0d7 187 $proto{to} = $self->expand_expr({ -as => [ $proto{to}, $as ] });
b99e9a14 188 }
e0eb8d26 189 if (defined($proto{using}) and ref(my $using = $proto{using}) ne 'HASH') {
13c99dad 190 $proto{using} = [
e0eb8d26 191 map [ $self->expand_expr($_, -ident) ],
192 ref($using) eq 'ARRAY' ? @$using: $using
13c99dad 193 ];
e0eb8d26 194 }
7741b7ad 195 my %ret = map +($_ => $self->expand_expr($proto{$_}, -ident)),
196 sort keys %proto;
197 return +{ -join => \%ret };
198}
199
200sub _render_from_list {
a01911a2 201 my ($self, undef, $list) = @_;
a1f8b6ef 202 return $self->join_query_parts(', ', @$list);
7741b7ad 203}
204
205sub _render_join {
a01911a2 206 my ($self, undef, $args) = @_;
7741b7ad 207
208 my @parts = (
412f9efe 209 $args->{from},
1601bb47 210 { -keyword => join '_', ($args->{type}||()), 'join' },
51ccda04 211 (map +($_->{-ident} || $_->{-as} ? $_ : ('(', $_, ')')), $args->{to}),
7741b7ad 212 ($args->{on} ? (
1601bb47 213 { -keyword => 'on' },
412f9efe 214 $args->{on},
7741b7ad 215 ) : ()),
216 ($args->{using} ? (
1601bb47 217 { -keyword => 'using' },
13c99dad 218 '(', $args->{using}, ')',
7741b7ad 219 ) : ()),
220 );
0236f122 221 return $self->join_query_parts(' ', @parts);
7741b7ad 222}
223
b99e9a14 224sub _expand_op_as {
225 my ($self, undef, $vv, $k) = @_;
984db0d7 226 my @vv = (ref($vv) eq 'ARRAY' ? @$vv : $vv);
984db0d7 227 my $ik = $self->expand_expr($k, -ident);
228 return +{ -as => [ $ik, $self->expand_expr($vv[0], -alias) ] }
229 if @vv == 1 and ref($vv[0]) eq 'HASH';
230
231 my @as = map $self->expand_expr($_, -ident), @vv;
232 return { -as => [ $ik, { -alias => \@as } ] };
b99e9a14 233}
234
235sub _render_as {
a01911a2 236 my ($self, undef, $args) = @_;
984db0d7 237 my ($thing, $alias) = @$args;
0236f122 238 return $self->join_query_parts(
ac7992be 239 ' ',
984db0d7 240 $thing,
1601bb47 241 { -keyword => 'as' },
984db0d7 242 $alias,
1ba47f38 243 );
244}
245
246sub _render_alias {
984db0d7 247 my ($self, undef, $args) = @_;
1ba47f38 248 my ($as, @cols) = @$args;
249 return (@cols
0236f122 250 ? $self->join_query_parts('',
a1f8b6ef 251 $as,
3f312d2e 252 '(',
253 $self->join_query_parts(
254 ', ',
255 @cols
256 ),
257 ')',
1ba47f38 258 )
259 : $self->render_aqt($as)
b99e9a14 260 );
261}
262
f9f1fdcd 263sub _expand_update_clause_target {
fe8b493f 264 my ($self, undef, $target) = @_;
f9f1fdcd 265 +(target => $self->_expand_from_list(undef, $target));
266}
267
2f4717ad 268sub _expand_cast {
269 my ($self, undef, $thing) = @_;
270 return { -func => [ cast => $thing ] } if ref($thing) eq 'HASH';
271 my ($cast, $to) = @{$thing};
272 +{ -func => [ cast => { -as => [
273 $self->expand_expr($cast),
274 $self->expand_expr($to, -ident),
275 ] } ] };
276}
277
278sub _expand_alias {
279 my ($self, undef, $args) = @_;
280 if (ref($args) eq 'HASH' and my $alias = $args->{-alias}) {
281 $args = $alias;
282 }
283 +{ -alias => [
284 map $self->expand_expr($_, -ident),
285 ref($args) eq 'ARRAY' ? @{$args} : $args
286 ]
287 }
288}
289
290sub _expand_with {
291 my ($self, $name, $with) = @_;
292 my (undef, $type) = split '_', $name;
293 if (ref($with) eq 'HASH') {
294 return +{
295 %$with,
296 queries => [
297 map +[
298 $self->expand_expr({ -alias => $_->[0] }, -ident),
299 $self->expand_expr($_->[1]),
300 ], @{$with->{queries}}
301 ]
302 }
303 }
304 my @with = @$with;
305 my @exp;
306 while (my ($alias, $query) = splice @with, 0, 2) {
307 push @exp, [
308 $self->expand_expr({ -alias => $alias }, -ident),
309 $self->expand_expr($query)
310 ];
311 }
312 return +(with => { ($type ? (type => $type) : ()), queries => \@exp });
313}
314
315sub _render_with {
316 my ($self, undef, $with) = @_;
317 my $q_part = $self->join_query_parts(', ',
318 map {
319 my ($alias, $query) = @$_;
320 $self->join_query_parts(' ',
321 $alias,
1601bb47 322 { -keyword => 'as' },
2f4717ad 323 $query,
324 )
325 } @{$with->{queries}}
326 );
327 return $self->join_query_parts(' ',
1601bb47 328 { -keyword => join '_', 'with', ($with->{type}||'') },
2f4717ad 329 $q_part,
330 );
331}
332
51046d0e 333sub _expand_setop {
334 my ($self, $setop, $args) = @_;
335 +{ "-${setop}" => {
336 %$args,
337 queries => [ map $self->expand_expr($_), @{$args->{queries}} ],
338 } };
339}
340
b5f4a869 341sub _render_setop {
342 my ($self, $setop, $args) = @_;
343 $self->join_query_parts(
1601bb47 344 { -keyword => ' '.join('_', $setop, ($args->{type}||())).' ' },
b5f4a869 345 @{$args->{queries}}
346 );
347}
348
41086177 349sub _expand_clause_setop {
350 my ($self, $setop, $args) = @_;
351 my ($op, $type) = split '_', $setop;
352 +(setop => $self->expand_expr({
353 "-${op}" => {
354 ($type ? (type => $type) : ()),
355 queries => (ref($args) eq 'ARRAY' ? $args : [ $args ])
356 }
357 }));
358}
359
1ff9018c 3601;
3001f097 361
583c7957 362__END__
363
3001f097 364=head1 NAME
365
366SQL::Abstract::ExtraClauses - new/experimental additions to L<SQL::Abstract>
367
368=head1 SYNOPSIS
369
370 my $sqla = SQL::Abstract->new;
371 SQL::Abstract::ExtraClauses->apply_to($sqla);
372
373=head1 METHODS
374
375=head2 apply_to
376
377Applies the plugin to an L<SQL::Abstract> object.
378
379=head2 cb
380
381For plugin authors, creates a callback to call a method on the plugin.
382
383=head2 sqla
384
385Available only during plugin callback executions, contains the currently
386active L<SQL::Abstract> object.
387
583c7957 388=head1 NODE TYPES
389
390=head2 alias
391
392Represents a table alias. Expands name and column names with ident as default.
393
394 # expr
395 { -alias => [ 't', 'x', 'y', 'z' ] }
396
397 # aqt
398 { -alias => [
399 { -ident => [ 't' ] }, { -ident => [ 'x' ] },
400 { -ident => [ 'y' ] }, { -ident => [ 'z' ] },
401 ] }
402
403 # query
404 t(x, y, z)
405 []
406
407=head2 as
408
409Represents an sql AS. LHS is expanded with ident as default, RHS is treated
410as a list of arguments for the alias node.
411
412 # expr
413 { foo => { -as => 'bar' } }
414
415 # aqt
416 { -as =>
417 [
418 { -ident => [ 'foo' ] },
419 { -alias => [ { -ident => [ 'bar' ] } ] },
420 ]
421 }
422
423 # query
424 foo AS bar
425 []
426
427 # expr
428 { -as => [ { -select => { _ => 'blah' } }, 't', 'blah' ] }
429
430 # aqt
431 { -as => [
432 { -select =>
433 { select => { -op => [ ',', { -ident => [ 'blah' ] } ] } }
434 },
435 { -alias => [ { -ident => [ 't' ] }, { -ident => [ 'blah' ] } ] },
436 ] }
437
438 # query
439 (SELECT blah) AS t(blah)
440 []
441
442=head2 cast
443
444 # expr
445 { -cast => [ { -ident => 'birthday' }, 'date' ] }
446
447 # aqt
448 { -func => [
449 'cast', {
450 -as => [ { -ident => [ 'birthday' ] }, { -ident => [ 'date' ] } ]
451 },
452 ] }
453
454 # query
455 CAST(birthday AS date)
456 []
457
3001f097 458=cut