test is case insensitive, result should be lower cased
[scpubgit/Q-Branch.git] / lib / SQL / Abstract / ExtraClauses.pm
1 package SQL::Abstract::ExtraClauses;
2
3 use strict;
4 use warnings;
5 use if $] < '5.010', 'MRO::Compat';
6 use mro 'c3';
7 use base qw(SQL::Abstract::Clauses);
8
9 BEGIN { *puke = \&SQL::Abstract::puke }
10
11 sub register_defaults {
12   my $self = shift;
13   $self->next::method(@_);
14   my @clauses = $self->clauses_of('select');
15   my @before_setop;
16   CLAUSE: foreach my $idx (0..$#clauses) {
17     if ($clauses[$idx] eq 'order_by') {
18       @before_setop = @clauses[0..$idx-1];
19       splice(@clauses, $idx, 0, qw(setop group_by having));
20       last CLAUSE;
21     }
22   }
23   die "Huh?" unless @before_setop;
24   $self->clauses_of(select => 'with', @clauses);
25   $self->clause_expanders(
26     'select.group_by', sub {
27       $_[0]->_expand_maybe_list_expr($_[2], -ident)
28     },
29     'select.having', sub { $_[0]->expand_expr($_[2]) },
30   );
31   foreach my $thing (qw(join from_list)) {
32     $self->expander($thing => "_expand_${thing}")
33          ->renderer($thing => "_render_${thing}")
34   }
35   $self->op_expander(as => '_expand_op_as');
36   $self->expander(as => '_expand_op_as');
37   $self->renderer(as => '_render_as');
38   $self->expander(alias => sub {
39     my ($self, undef, $args) = @_;
40     if (ref($args) eq 'HASH' and my $alias = $args->{-alias}) {
41       $args = $alias;
42     }
43     +{ -alias => [
44         map $self->expand_expr($_, -ident),
45         ref($args) eq 'ARRAY' ? @{$args} : $args
46       ]
47     }
48   });
49   $self->renderer(alias => '_render_alias');
50
51   $self->clauses_of(update => sub {
52     my ($self, @clauses) = @_;
53     splice(@clauses, 2, 0, 'from');
54     @clauses;
55   });
56
57   $self->clauses_of(delete => sub {
58     my ($self, @clauses) = @_;
59     splice(@clauses, 1, 0, 'using');
60     @clauses;
61   });
62
63   $self->clause_expanders(
64     'update.from' => '_expand_select_clause_from',
65     'delete.using' => sub {
66       +(using => $_[0]->_expand_from_list(undef, $_[2]));
67     },
68     'insert.rowvalues' => sub {
69       +(from => $_[0]->expand_expr({ -values => $_[2] }));
70     },
71     'insert.select' => sub {
72       +(from => $_[0]->expand_expr({ -select => $_[2] }));
73     },
74   );
75
76   # set ops
77   $self->wrap_expander(select => sub {
78     my $orig = shift;
79     sub {
80       my $self = shift;
81       my $exp = $self->$orig(@_);
82       return $exp unless my $setop = (my $sel = $exp->{-select})->{setop};
83       if (my @keys = grep $sel->{$_}, @before_setop) {
84         my %inner; @inner{@keys} = delete @{$sel}{@keys};
85         unshift @{(values(%$setop))[0]{queries}},
86           { -select => \%inner };
87       }
88       return $exp;
89     }
90   });
91   my $expand_setop = sub {
92     my ($self, $setop, $args) = @_;
93     +{ "-${setop}" => {
94          %$args,
95          queries => [ map $self->expand_expr($_), @{$args->{queries}} ],
96     } };
97   };
98   $self->expanders(map +($_ => $expand_setop), qw(union intersect except));
99
100   $self->clause_renderer('select.setop' => sub {
101     my ($self, undef, $setop) = @_;
102     $self->render_aqt($setop);
103   });
104
105   $self->renderer($_ => sub {
106     my ($self, $setop, $args) = @_;
107     $self->join_query_parts(
108       ' '.$self->format_keyword(join '_', $setop, ($args->{type}||())).' ',
109       @{$args->{queries}}
110     );
111   }) for qw(union intersect except);
112
113   my $setop_expander = sub {
114     my ($self, $setop, $args) = @_;
115     my ($op, $type) = split '_', $setop;
116     +(setop => $self->expand_expr({
117       "-${op}" => {
118         ($type ? (type => $type) : ()),
119         queries => (ref($args) eq 'ARRAY' ? $args : [ $args ])
120       }
121     }));
122   };
123
124   $self->clause_expanders(
125     map +($_ => $setop_expander),
126       map "select.${_}",
127         map +($_, "${_}_all", "${_}_distinct"),
128           qw(union intersect except)
129   );
130
131   $self->clause_expander('select.with' => my $with_expander = sub {
132     my ($self, $name, $with) = @_;
133     my (undef, $type) = split '_', $name;
134     if (ref($with) eq 'HASH') {
135       return +{
136         %$with,
137         queries => [
138           map +[
139             $self->expand_expr({ -alias => $_->[0] }, -ident),
140             $self->expand_expr($_->[1]),
141           ], @{$with->{queries}}
142         ]
143       }
144     }
145     my @with = @$with;
146     my @exp;
147     while (my ($alias, $query) = splice @with, 0, 2) {
148       push @exp, [
149         $self->expand_expr({ -alias => $alias }, -ident),
150         $self->expand_expr($query)
151       ];
152     }
153     return +(with => { ($type ? (type => $type) : ()), queries => \@exp });
154   });
155   $self->clause_expander('select.with_recursive', $with_expander);
156   $self->clause_renderer('select.with' => my $with_renderer = sub {
157     my ($self, undef, $with) = @_;
158     my $q_part = $self->join_query_parts(', ',
159       map {
160         my ($alias, $query) = @$_;
161         $self->join_query_parts(' ',
162             $alias,
163             $self->format_keyword('as'),
164             $query,
165         )
166       } @{$with->{queries}}
167     );
168     return $self->join_query_parts(' ',
169       $self->format_keyword(join '_', 'with', ($with->{type}||'')),
170       $q_part,
171     );
172   });
173   foreach my $stmt (qw(insert update delete)) {
174     $self->clauses_of($stmt => 'with', $self->clauses_of($stmt));
175     $self->clause_expander("${stmt}.$_", $with_expander)
176       for qw(with with_recursive);
177     $self->clause_renderer("${stmt}.with", $with_renderer);
178   }
179   $self->expander(cast => sub {
180     return { -func => [ cast => $_[2] ] } if ref($_[2]) eq 'HASH';
181     my ($cast, $to) = @{$_[2]};
182     +{ -func => [ cast => { -as => [
183       $self->expand_expr($cast),
184       $self->expand_expr($to, -ident),
185     ] } ] };
186   });
187
188   return $self;
189 }
190
191 sub _expand_select_clause_from {
192   my ($self, undef, $from) = @_;
193   +(from => $self->_expand_from_list(undef, $from));
194 }
195
196 sub _expand_from_list {
197   my ($self, undef, $args) = @_;
198   if (ref($args) eq 'HASH') {
199     return $args if $args->{-from_list};
200     return { -from_list => [ $self->expand_expr($args) ] };
201   }
202   my @list;
203   my @args = ref($args) eq 'ARRAY' ? @$args : ($args);
204   while (my $entry = shift @args) {
205     if (!ref($entry) and $entry =~ /^-(.*)/) {
206       if ($1 eq 'as') {
207         $list[-1] = $self->expand_expr({ -as => [
208           $list[-1], map +(ref($_) eq 'ARRAY' ? @$_ : $_), shift(@args)
209         ]});
210         next;
211       }
212       $entry = { $entry => shift @args };
213     }
214     my $aqt = $self->expand_expr($entry, -ident);
215     if ($aqt->{-join} and not $aqt->{-join}{from}) {
216       $aqt->{-join}{from} = pop @list;
217     }
218     push @list, $aqt;
219   }
220   return { -from_list => \@list };
221 }
222
223 sub _expand_join {
224   my ($self, undef, $args) = @_;
225   my %proto = (
226     ref($args) eq 'HASH'
227       ? %$args
228       : (to => $args->[0], @{$args}[1..$#$args])
229   );
230   if (my $as = delete $proto{as}) {
231     $proto{to} = $self->expand_expr({ -as => [ $proto{to}, $as ] });
232   }
233   if (defined($proto{using}) and ref(my $using = $proto{using}) ne 'HASH') {
234     $proto{using} = [
235       map [ $self->expand_expr($_, -ident) ],
236         ref($using) eq 'ARRAY' ? @$using: $using
237     ];
238   }
239   my %ret = map +($_ => $self->expand_expr($proto{$_}, -ident)),
240               sort keys %proto;
241   return +{ -join => \%ret };
242 }
243
244 sub _render_from_list {
245   my ($self, undef, $list) = @_;
246   return $self->join_query_parts(', ', @$list);
247 }
248
249 sub _render_join {
250   my ($self, undef, $args) = @_;
251
252   my @parts = (
253     $args->{from},
254     $self->format_keyword(join '_', ($args->{type}||()), 'join'),
255     (map +($_->{-ident} || $_->{-as} ? $_ : ('(', $_, ')')), $args->{to}),
256     ($args->{on} ? (
257       $self->format_keyword('on') ,
258       $args->{on},
259     ) : ()),
260     ($args->{using} ? (
261       $self->format_keyword('using'),
262       '(', $args->{using}, ')',
263     ) : ()),
264   );
265   return $self->join_query_parts(' ', @parts);
266 }
267
268 sub _expand_op_as {
269   my ($self, undef, $vv, $k) = @_;
270   my @vv = (ref($vv) eq 'ARRAY' ? @$vv : $vv);
271   $k ||= shift @vv;
272   my $ik = $self->expand_expr($k, -ident);
273   return +{ -as => [ $ik, $self->expand_expr($vv[0], -alias) ] }
274     if @vv == 1 and ref($vv[0]) eq 'HASH';
275
276   my @as = map $self->expand_expr($_, -ident), @vv;
277   return { -as => [ $ik, { -alias => \@as } ] };
278 }
279
280 sub _render_as {
281   my ($self, undef, $args) = @_;
282   my ($thing, $alias) = @$args;
283   return $self->join_query_parts(
284     ' ',
285     $thing,
286     $self->format_keyword('as'),
287     $alias,
288   );
289 }
290
291 sub _render_alias {
292   my ($self, undef, $args) = @_;
293   my ($as, @cols) = @$args;
294   return (@cols
295     ? $self->join_query_parts('',
296          $as,
297          '(',
298          $self->join_query_parts(
299            ', ',
300            @cols
301          ),
302          ')',
303       )
304     : $self->render_aqt($as)
305   );
306 }
307
308 sub _expand_update_clause_target {
309   my ($self, undef, $target) = @_;
310   +(target => $self->_expand_from_list(undef, $target));
311 }
312
313 1;