document group by and having clauses
[dbsrgits/SQL-Abstract.git] / lib / SQL / Abstract / ExtraClauses.pm
1 package SQL::Abstract::ExtraClauses;
2
3 use Moo;
4
5 has sqla => (
6   is => 'ro', init_arg => undef,
7   handles => [ qw(
8     expand_expr render_aqt join_query_parts
9   ) ],
10 );
11
12 sub cb {
13   my ($self, $method, @args) = @_;
14   return sub {
15     local $self->{sqla} = shift;
16     $self->$method(@args, @_)
17   };
18 }
19
20 sub register {
21   my ($self, @pairs) = @_;
22   my $sqla = $self->sqla;
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     }
28   }
29   return $self;
30 }
31
32 sub apply_to {
33   my ($self, $sqla) = @_;
34   $self = $self->new unless ref($self);
35   local $self->{sqla} = $sqla;
36   $self->register_extensions($sqla);
37 }
38
39 sub register_extensions {
40   my ($self, $sqla) = @_;
41
42   my @clauses = $sqla->clauses_of('select');
43   my @before_setop;
44   CLAUSE: foreach my $idx (0..$#clauses) {
45     if ($clauses[$idx] eq 'order_by') {
46       @before_setop = @clauses[0..$idx-1];
47       splice(@clauses, $idx, 0, qw(setop group_by having));
48       last CLAUSE;
49     }
50   }
51
52   die "Huh?" unless @before_setop;
53   $sqla->clauses_of(select => @clauses);
54
55   $sqla->clauses_of(update => sub {
56     my ($self, @clauses) = @_;
57     splice(@clauses, 2, 0, 'from');
58     @clauses;
59   });
60
61   $sqla->clauses_of(delete => sub {
62     my ($self, @clauses) = @_;
63     splice(@clauses, 1, 0, 'using');
64     @clauses;
65   });
66
67   $self->register(
68     (map +(
69       "${_}er" => [
70         do {
71           my $x = $_;
72           (map +($_ => "_${x}_${_}"), qw(join from_list alias))
73         }
74        ]
75     ), qw(expand render)),
76     binop_expander => [ as => '_expand_op_as' ],
77     renderer => [ as => '_render_as' ],
78     expander => [ cast => '_expand_cast' ],
79     clause_expanders => [
80       "select.from", '_expand_from_list',
81       'select.group_by'
82         => sub { $_[0]->expand_expr({ -list => $_[2] }, -ident) },
83       'select.having'
84         => sub { $_[0]->expand_expr($_[2]) },
85       'update.from' => '_expand_from_list',
86       "update.target", '_expand_update_clause_target',
87       "update.update", '_expand_update_clause_target',
88       'delete.using' => '_expand_from_list',
89       'insert.rowvalues' => sub {
90         +(from => $_[0]->expand_expr({ -values => $_[2] }));
91       },
92       'insert.select' => sub {
93         +(from => $_[0]->expand_expr({ -select => $_[2] }));
94       },
95     ],
96   );
97
98   # set ops
99   $sqla->wrap_expander(select => sub {
100     $self->cb('_expand_select', $_[0], \@before_setop);
101   });
102
103   $self->register(
104     clause_renderer => [
105       'select.setop' => sub { $_[0]->render_aqt($_[2]) }
106     ],
107     expander => [ map +($_ => '_expand_setop'), qw(union intersect except) ],
108     renderer => [ map +($_ => '_render_setop'), qw(union intersect except) ],
109   );
110
111   my $setop_expander = $self->cb('_expand_clause_setop');
112
113   $sqla->clause_expanders(
114     map +($_ => $setop_expander),
115       map "select.${_}",
116         map +($_, "${_}_all", "${_}_distinct"),
117           qw(union intersect except)
118   );
119
120   foreach my $stmt (qw(select insert update delete)) {
121     $sqla->clauses_of($stmt => 'with', $sqla->clauses_of($stmt));
122     $self->register(
123       clause_expanders => [
124         "${stmt}.with" => '_expand_with',
125         "${stmt}.with_recursive" => '_expand_with',
126       ],
127       clause_renderer => [ "${stmt}.with" => '_render_with' ],
128     );
129   }
130
131   return $sqla;
132 }
133
134 sub _expand_select {
135   my ($self, $orig, $before_setop, @args) = @_;
136   my $exp = $self->sqla->$orig(@args);
137   return $exp unless my $setop = (my $sel = $exp->{-select})->{setop};
138   if (my @keys = grep $sel->{$_}, @$before_setop) {
139     my %inner; @inner{@keys} = delete @{$sel}{@keys};
140     unshift @{(values(%$setop))[0]{queries}},
141       { -select => \%inner };
142   }
143   return $exp;
144 }
145
146 sub _expand_from_list {
147   my ($self, undef, $args) = @_;
148   if (ref($args) eq 'HASH') {
149     return $args if $args->{-from_list};
150     return { -from_list => [ $self->expand_expr($args) ] };
151   }
152   my @list;
153   my @args = ref($args) eq 'ARRAY' ? @$args : ($args);
154   while (my $entry = shift @args) {
155     if (!ref($entry) and $entry =~ /^-(.*)/) {
156       if ($1 eq 'as') {
157         $list[-1] = $self->expand_expr({ -as => [
158           $list[-1], map +(ref($_) eq 'ARRAY' ? @$_ : $_), shift(@args)
159         ]});
160         next;
161       }
162       $entry = { $entry => shift @args };
163     }
164     my $aqt = $self->expand_expr($entry, -ident);
165     if ($aqt->{-join} and not $aqt->{-join}{from}) {
166       $aqt->{-join}{from} = pop @list;
167     }
168     push @list, $aqt;
169   }
170   return $list[0] if @list == 1;
171   return { -from_list => \@list };
172 }
173
174 sub _expand_join {
175   my ($self, undef, $args) = @_;
176   my %proto = (
177     ref($args) eq 'HASH'
178       ? %$args
179       : (to => @$args)
180   );
181   if (my $as = delete $proto{as}) {
182     $proto{to} = $self->expand_expr(
183                    { -as => [ { -from_list => $proto{to} }, $as ] }
184                  );
185   }
186   if (defined($proto{using}) and ref(my $using = $proto{using}) ne 'HASH') {
187     $proto{using} = [
188       map [ $self->expand_expr($_, -ident) ],
189         ref($using) eq 'ARRAY' ? @$using: $using
190     ];
191   }
192   my %ret = (
193     type => delete $proto{type},
194     to => $self->expand_expr({ -from_list => delete $proto{to} }, -ident)
195   );
196   %ret = (%ret,
197     map +($_ => $self->expand_expr($proto{$_}, -ident)),
198       sort keys %proto
199   );
200   return +{ -join => \%ret };
201 }
202
203 sub _render_from_list {
204   my ($self, undef, $list) = @_;
205   return $self->join_query_parts(', ', @$list);
206 }
207
208 sub _render_join {
209   my ($self, undef, $args) = @_;
210
211   my @parts = (
212     $args->{from},
213     { -keyword => join '_', ($args->{type}||()), 'join' },
214     (map +($_->{-ident} || $_->{-as}
215       ? $_
216       : ('(', $self->render_aqt($_, 1), ')')),
217         map +(@{$_->{-from_list}||[]} == 1 ? $_->{-from_list}[0] : $_),
218           $args->{to}
219     ),
220     ($args->{on} ? (
221       { -keyword => 'on' },
222       $args->{on},
223     ) : ()),
224     ($args->{using} ? (
225       { -keyword => 'using' },
226       '(', $args->{using}, ')',
227     ) : ()),
228   );
229   return $self->join_query_parts(' ', @parts);
230 }
231
232 sub _expand_op_as {
233   my ($self, undef, $vv, $k) = @_;
234   my @vv = (ref($vv) eq 'ARRAY' ? @$vv : $vv);
235   my $ik = $self->expand_expr($k, -ident);
236   return +{ -as => [ $ik, $self->expand_expr($vv[0], -ident) ] }
237     if @vv == 1 and ref($vv[0]) eq 'HASH';
238
239   my @as = map $self->expand_expr($_, -ident), @vv;
240   return { -as => [ $ik, $self->expand_expr({ -alias => \@as }) ] };
241 }
242
243 sub _render_as {
244   my ($self, undef, $args) = @_;
245   my ($thing, $alias) = @$args;
246   return $self->join_query_parts(
247     ' ',
248     $thing,
249     { -keyword => 'as' },
250     $alias,
251   );
252 }
253
254 sub _render_alias {
255   my ($self, undef, $args) = @_;
256   my ($as, @cols) = @$args;
257   return (@cols
258     ? $self->join_query_parts('',
259          $as,
260          '(',
261          $self->join_query_parts(
262            ', ',
263            @cols
264          ),
265          ')',
266       )
267     : $self->render_aqt($as)
268   );
269 }
270
271 sub _expand_update_clause_target {
272   my ($self, undef, $target) = @_;
273   +(target => $self->_expand_from_list(undef, $target));
274 }
275
276 sub _expand_cast {
277   my ($self, undef, $thing) = @_;
278   return { -func => [ cast => $thing ] } if ref($thing) eq 'HASH';
279   my ($cast, $to) = @{$thing};
280   +{ -func => [ cast => { -as => [
281     $self->expand_expr($cast),
282     $self->expand_expr($to, -ident),
283   ] } ] };
284 }
285
286 sub _expand_alias {
287   my ($self, undef, $args) = @_;
288   if (ref($args) eq 'HASH' and my $alias = $args->{-alias}) {
289     $args = $alias;
290   }
291   my @parts = map $self->expand_expr($_, -ident),
292                 ref($args) eq 'ARRAY' ? @{$args} : $args;
293   return $parts[0] if @parts == 1;
294   return { -alias => \@parts };
295 }
296
297 sub _expand_with {
298   my ($self, $name, $with) = @_;
299   my (undef, $type) = split '_', $name;
300   if (ref($with) eq 'HASH') {
301     return +{
302       %$with,
303       queries => [
304         map +[
305           $self->expand_expr({ -alias => $_->[0] }, -ident),
306           $self->expand_expr($_->[1]),
307         ], @{$with->{queries}}
308       ]
309     }
310   }
311   my @with = @$with;
312   my @exp;
313   while (my ($alias, $query) = splice @with, 0, 2) {
314     push @exp, [
315       $self->expand_expr({ -alias => $alias }, -ident),
316       $self->expand_expr($query)
317     ];
318   }
319   return +(with => { ($type ? (type => $type) : ()), queries => \@exp });
320 }
321
322 sub _render_with {
323   my ($self, undef, $with) = @_;
324   my $q_part = $self->join_query_parts(', ',
325     map {
326       my ($alias, $query) = @$_;
327       $self->join_query_parts(' ',
328           $alias,
329           { -keyword => 'as' },
330           $query,
331       )
332     } @{$with->{queries}}
333   );
334   return $self->join_query_parts(' ',
335     { -keyword => join '_', 'with', ($with->{type}||'') },
336     $q_part,
337   );
338 }
339
340 sub _expand_setop {
341   my ($self, $setop, $args) = @_;
342   +{ "-${setop}" => {
343        %$args,
344        queries => [ map $self->expand_expr($_), @{$args->{queries}} ],
345   } };
346 }
347
348 sub _render_setop {
349   my ($self, $setop, $args) = @_;
350   $self->join_query_parts(
351     { -keyword => ' '.join('_', $setop, ($args->{type}||())).' ' },
352     @{$args->{queries}}
353   );
354 }
355
356 sub _expand_clause_setop {
357   my ($self, $setop, $args) = @_;
358   my ($op, $type) = split '_', $setop;
359   +(setop => $self->expand_expr({
360     "-${op}" => {
361       ($type ? (type => $type) : ()),
362       queries => (ref($args) eq 'ARRAY' ? $args : [ $args ])
363     }
364   }));
365 }
366
367 1;
368
369 __END__
370
371 =head1 NAME
372
373 SQL::Abstract::ExtraClauses - new/experimental additions to L<SQL::Abstract>
374
375 =head1 SYNOPSIS
376
377   my $sqla = SQL::Abstract->new;
378   SQL::Abstract::ExtraClauses->apply_to($sqla);
379
380 =head1 WARNING
381
382 This module is basically a nursery for things that seem like a good idea
383 to live in until we figure out if we were right about that.
384
385 =head1 METHODS
386
387 =head2 apply_to
388
389 Applies the plugin to an L<SQL::Abstract> object.
390
391 =head2 register_extensions
392
393 Registers the extensions described below
394
395 =head2 cb
396
397 For plugin authors, creates a callback to call a method on the plugin.
398
399 =head2 register
400
401 For plugin authors, registers callbacks more easily.
402
403 =head2 sqla
404
405 Available only during plugin callback executions, contains the currently
406 active L<SQL::Abstract> object.
407
408 =head1 NODE TYPES
409
410 =head2 alias
411
412 Represents a table alias. Expands name and column names with ident as default.
413
414   # expr
415   { -alias => [ 't', 'x', 'y', 'z' ] }
416
417   # aqt
418   { -alias => [
419       { -ident => [ 't' ] }, { -ident => [ 'x' ] },
420       { -ident => [ 'y' ] }, { -ident => [ 'z' ] },
421   ] }
422
423   # query
424   t(x, y, z)
425   []
426
427 =head2 as
428
429 Represents an sql AS. LHS is expanded with ident as default, RHS is treated
430 as a list of arguments for the alias node.
431
432   # expr
433   { foo => { -as => 'bar' } }
434
435   # aqt
436   { -as => [ { -ident => [ 'foo' ] }, { -ident => [ 'bar' ] } ] }
437
438   # query
439   foo AS bar
440   []
441
442   # expr
443   { -as => [ { -select => { _ => 'blah' } }, 't', 'blah' ] }
444
445   # aqt
446   { -as => [
447       { -select =>
448           { select => { -op => [ ',', { -ident => [ 'blah' ] } ] } }
449       },
450       { -alias => [ { -ident => [ 't' ] }, { -ident => [ 'blah' ] } ] },
451   ] }
452
453   # query
454   (SELECT blah) AS t(blah)
455   []
456
457 =head2 cast
458
459   # expr
460   { -cast => [ { -ident => 'birthday' }, 'date' ] }
461
462   # aqt
463   { -func => [
464       'cast', {
465         -as => [ { -ident => [ 'birthday' ] }, { -ident => [ 'date' ] } ]
466       },
467   ] }
468
469   # query
470   CAST(birthday AS date)
471   []
472
473 =head2 join
474
475 If given an arrayref, pretends it was given a hashref with the first
476 element of the arrayref as the value for 'to' and the remaining pairs copied.
477
478 Given a hashref, the 'as' key is if presented expanded to wrap the 'to'.
479
480 If present the 'using' key is expanded as a list of idents.
481
482 Known keys are: 'from' (the left hand side), 'type' ('left', 'right', or
483 nothing), 'to' (the right hand side), 'on' and 'using'.
484
485   # expr
486   { -join => {
487       from => 'lft',
488       on => { 'lft.bloo' => { '>' => 'rgt.blee' } },
489       to => 'rgt',
490       type => 'left',
491   } }
492
493   # aqt
494   { -join => {
495       from => { -ident => [ 'lft' ] },
496       on => { -op => [
497           '>', { -ident => [ 'lft', 'bloo' ] },
498           { -ident => [ 'rgt', 'blee' ] },
499       ] },
500       to => { -ident => [ 'rgt' ] },
501       type => 'left',
502   } }
503
504   # query
505   lft LEFT JOIN rgt ON lft.bloo > rgt.blee
506   []
507
508 =head2 from_list
509
510 List of components of the FROM clause; -foo type elements indicate a pair
511 with the next element; this is easiest if I show you:
512
513   # expr
514   { -from_list => [
515       't1', -as => 'table_one', -join =>
516       [ 't2', 'on', { 'table_one.x' => 't2.x' } ],
517   ] }
518
519   # aqt
520   { -join => {
521       from =>
522         {
523           -as => [ { -ident => [ 't1' ] }, { -ident => [ 'table_one' ] } ]
524         },
525       on => { -op => [
526           '=', { -ident => [ 'table_one', 'x' ] },
527           { -ident => [ 't2', 'x' ] },
528       ] },
529       to => { -ident => [ 't2' ] },
530       type => undef,
531   } }
532
533   # query
534   t1 AS table_one JOIN t2 ON table_one.x = t2.x
535   []
536
537 Or with using:
538
539   # expr
540   { -from_list =>
541       [ 't1', -as => 'table_one', -join => [ 't2', 'using', [ 'x' ] ] ]
542   }
543
544   # aqt
545   { -join => {
546       from =>
547         {
548           -as => [ { -ident => [ 't1' ] }, { -ident => [ 'table_one' ] } ]
549         },
550       to => { -ident => [ 't2' ] },
551       type => undef,
552       using =>
553         { -op => [ 'or', { -op => [ 'or', { -ident => [ 'x' ] } ] } ] },
554   } }
555
556   # query
557   t1 AS table_one JOIN t2 USING ( x )
558   []
559
560 With oddities:
561
562   # expr
563   { -from_list => [
564       'x', -join =>
565       [ [ 'y', -join => [ 'z', 'type', 'left' ] ], 'type', 'left' ],
566   ] }
567
568   # aqt
569   { -join => {
570       from => { -ident => [ 'x' ] },
571       to => { -join => {
572           from => { -ident => [ 'y' ] },
573           to => { -ident => [ 'z' ] },
574           type => 'left',
575       } },
576       type => 'left',
577   } }
578
579   # query
580   x LEFT JOIN ( y LEFT JOIN z )
581   []
582
583 =head1 STATEMENT EXTENSIONS
584
585 =head2 group by clause for select
586
587 Expanded as a list with an ident default:
588
589   # expr
590   { -select => { group_by => [ 'foo', 'bar' ] } }
591
592   # aqt
593   { -select => { group_by =>
594         {
595           -op => [ ',', { -ident => [ 'foo' ] }, { -ident => [ 'bar' ] } ]
596         }
597   } }
598
599   # query
600   GROUP BY foo, bar
601   []
602
603 =head2 having clause for select
604
605 Basic expr, just like where, given having is pretty much post-group-by
606 where clause:
607
608   # expr
609   { -select =>
610       { having => { '>' => [ { -count => { -ident => 'foo' } }, 3 ] } }
611   }
612
613   # aqt
614   { -select => { having => { -op => [
615           '>', { -func => [ 'count', { -ident => [ 'foo' ] } ] },
616           { -bind => [ undef, 3 ] },
617   ] } } }
618
619   # query
620   HAVING COUNT(foo) > ?
621   [ 3 ]
622
623 =cut