Simple between support
[dbsrgits/SQL-Abstract-2.0-ish.git] / lib / SQL / Abstract / AST / v1.pm
CommitLineData
14774be0 1use MooseX::Declare;
2
3class SQL::Abstract::AST::v1 extends SQL::Abstract {
4
5 use Carp qw/croak/;
6 use Data::Dump qw/pp/;
7
8 use Moose::Util::TypeConstraints;
cbcfedc1 9 use MooseX::Types::Moose qw/ArrayRef Str Int Ref HashRef/;
14774be0 10 use MooseX::AttributeHelpers;
bad761ba 11 use SQL::Abstract::Types qw/AST/;
ef0d6124 12 use Devel::PartialDump qw/dump/;
14774be0 13
14 clean;
15
0c371882 16 # set things that are valid in where clauses
ef0d6124 17 override _build_expr_dispatch_table {
0bf8a8c4 18 return {
19 %{super()},
1b85673a 20 in => $self->can('_in'),
21 not_in => $self->can('_in'),
1f4bd99c 22 between => $self->can('_between'),
23 not_between => $self->can('_between'),
a464be15 24 and => $self->can('_recurse_where'),
25 or => $self->can('_recurse_where'),
1b85673a 26 map { +"$_" => $self->can("_$_") } qw/
0c371882 27 value
28 name
29 true
30 false
e7996b3a 31 expr
0c371882 32 /
0bf8a8c4 33 };
14774be0 34 }
35
bad761ba 36 method _select(AST $ast) {
747f7c21 37 # Default to requiring columns and from.
38 # DB specific ones (i.e. mysql/Pg) can not require the FROM part with a bit
39 # of refactoring
40
41 for (qw/columns tablespec/) {
42 confess "'$_' is required in select AST with " . dump ($ast)
43 unless exists $ast->{$_};
4ee32f41 44 }
45
46 # Check that columns is a -list
747f7c21 47 confess "'columns' should be an array ref, not " . dump($ast->{columns})
48 unless is_ArrayRef($ast->{columns});
49
64c32031 50 my $cols = $self->_list({-type => 'list', args => $ast->{columns} });
4ee32f41 51
52 my @output = (
747f7c21 53 SELECT => $cols
4ee32f41 54 );
55
747f7c21 56 push @output, FROM => $self->dispatch($ast->{tablespec})
57 if exists $ast->{tablespec};
58
924d940e 59 if (exists $ast->{where}) {
60 my $sub_ast = $ast->{where};
61
62 confess "$_ option is not an AST: " . dump($sub_ast)
63 unless is_AST($sub_ast);
64
65 push @output, "WHERE", $self->_expr($sub_ast);
66 }
67
68 for (qw/group_by having order_by/) {
4ee32f41 69 if (exists $ast->{$_}) {
70 my $sub_ast = $ast->{$_};
e68f980b 71
924d940e 72 confess "$_ option is not an AST or an ArrayRef: " . dump($sub_ast)
73 unless is_AST($sub_ast) || is_ArrayRef($sub_ast);;
4ee32f41 74
e68f980b 75 my $meth = "__$_";
76 push @output, $self->$meth($sub_ast);
4ee32f41 77 }
78 }
79
80 return join(' ', @output);
14774be0 81 }
82
64c32031 83 method _join(HashRef $ast) {
d0ad3a92 84
85 # TODO: Validate join type
86 my $type = $ast->{join_type} || "";
14774be0 87
f7dc4536 88 my @output = $self->dispatch($ast->{lhs});
d0ad3a92 89
90 push @output, uc $type if $type;
f7dc4536 91 push @output, "JOIN", $self->dispatch($ast->{rhs});
64c32031 92
d0ad3a92 93 push @output,
94 exists $ast->{on}
95 ? ('ON', '(' . $self->_expr( $ast->{on} ) . ')' )
924d940e 96 : ('USING', '(' .$self->dispatch($ast->{using}
97 || croak "No 'on' or 'uinsg' clause passed to join cluase: " .
98 dump($ast)
99 ) .
d0ad3a92 100 ')' );
64c32031 101
d0ad3a92 102 return join(" ", @output);
64c32031 103
14774be0 104 }
105
924d940e 106 method _ordering(AST $ast) {
107
108 my $output = $self->_expr($ast->{expr});
109
110 $output .= " " . uc $1
111 if $ast->{direction} &&
112 ( $ast->{direction} =~ /^(asc|desc)$/i
113 || confess "Unknown ordering direction " . dump($ast)
114 );
14774be0 115
924d940e 116 return $output;
14774be0 117 }
118
bad761ba 119 method _name(AST $ast) {
7a56723e 120 my @names = @{$ast->{args}};
14774be0 121
122 my $sep = $self->name_separator;
4ee32f41 123 my $quote = $self->is_quoting
124 ? $self->quote_chars
125 : [ '' ];
126
127 my $join = $quote->[-1] . $sep . $quote->[0];
14774be0 128
4ee32f41 129 # We dont want to quote * in [qw/me */]: `me`.* is the desired output there
130 # This means you can't have a field called `*`. I am willing to accept this
131 # situation, cos thats a really stupid thing to want.
132 my $post;
133 $post = pop @names if $names[-1] eq '*';
14774be0 134
8b398780 135 my $ret;
136 $ret = $quote->[0] .
137 join( $join, @names ) .
138 $quote->[-1]
139 if @names;
140
141 $ret = $ret
142 ? $ret . $sep . $post
143 : $post
144 if defined $post;
145
4ee32f41 146
4ee32f41 147 return $ret;
14774be0 148 }
149
14774be0 150
7a56723e 151 method _list(AST $ast) {
e6a33ce3 152 return "" unless $ast->{args};
153
924d940e 154 my @items = is_ArrayRef($ast->{args})
155 ? @{$ast->{args}}
156 : $ast->{args};
14774be0 157
158 return join(
159 $self->list_separator,
160 map { $self->dispatch($_) } @items);
161 }
162
747f7c21 163 # TODO: I think i want to parameterized AST type to get better validation
7a56723e 164 method _alias(AST $ast) {
165
4ee32f41 166 # TODO: Maybe we want qq{ AS "$as"} here
7a56723e 167 return $self->dispatch($ast->{ident}) . " AS " . $ast->{as};
14774be0 168
169 }
170
bad761ba 171 method _value(AST $ast) {
14774be0 172
1b85673a 173 $self->add_bind($ast->{value});
14774be0 174 return "?";
175 }
176
e68f980b 177 # Not dispatchable to.
924d940e 178 method __having($args) {
179 return "HAVING " . $self->_list({-type => 'list', args => $args});
180 }
181
182 method __group_by($args) {
183 return "GROUP BY " . $self->_list({-type => 'list', args => $args});
e68f980b 184 }
185
924d940e 186 method __order_by($args) {
187 return "ORDER BY " . $self->_list({-type => 'list', args => $args});
188 }
189
190
ef0d6124 191 # Perhaps badly named. handles 'and' and 'or' clauses
bad761ba 192 method _recurse_where(AST $ast) {
14774be0 193
a464be15 194 my $op = $ast->{op};
14774be0 195
a464be15 196 my $OP = uc $op;
197 my $prio = $SQL::Abstract::PRIO{$op};
14774be0 198
ef0d6124 199 my $dispatch_table = $self->expr_dispatch_table;
0bf8a8c4 200
14774be0 201 my @output;
a464be15 202 foreach ( @{$ast->{args}} ) {
bad761ba 203 croak "invalid component in where clause: $_" unless is_AST($_);
14774be0 204
9d7d0694 205 if ($_->{-type} eq 'expr' && $_->{op} =~ /^(and|or)$/) {
14774be0 206 my $sub_prio = $SQL::Abstract::PRIO{$1};
207
208 if ($sub_prio <= $prio) {
209 push @output, $self->_recurse_where($_);
210 } else {
211 push @output, '(' . $self->_recurse_where($_) . ')';
212 }
213 } else {
ef0d6124 214 push @output, $self->_expr($_);
14774be0 215 }
216 }
217
218 return join(" $OP ", @output);
219 }
220
bad761ba 221 method _expr(AST $ast) {
1b85673a 222 my $op = $ast->{-type};
0c371882 223
ef0d6124 224 $op = $ast->{op} if $op eq 'expr';
225
226 if (my $code = $self->lookup_expr_dispatch($op)) {
0c371882 227
228 return $code->($self, $ast);
229
230 }
ef0d6124 231 croak "'$op' is not a valid AST type in an expression with " . dump($ast)
232 if $ast->{-type} ne 'expr';
0c371882 233
e6a33ce3 234 # This is an attempt to do some form of validation on function names. This
235 # might end up being a bad thing.
236 croak "'$op' is not a valid operator in an expression with " . dump($ast)
237 if $op =~ /\W/;
238
239 return $self->_generic_function_op($ast);
1b85673a 240
1b85673a 241 }
0c371882 242
bad761ba 243 method _binop(AST $ast) {
1b85673a 244 my ($lhs, $rhs) = @{$ast->{args}};
245 my $op = $ast->{op};
0bf8a8c4 246
ef0d6124 247 join (' ', $self->_expr($lhs),
0bf8a8c4 248 $self->binop_mapping($op) || croak("Unknown binary operator $op"),
ef0d6124 249 $self->_expr($rhs)
14774be0 250 );
251 }
252
e6a33ce3 253 method _generic_function_op(AST $ast) {
254 my $op = $ast->{op};
255
256 return "$op(" . $self->_list($ast) . ")";
257 }
258
bad761ba 259 method _in(AST $ast) {
a464be15 260
9d7d0694 261 my ($field,@values) = @{$ast->{args}};
a464be15 262
9d7d0694 263 my $not = ($ast->{op} =~ /^not_/) ? " NOT" : "";
0bf8a8c4 264
9d7d0694 265 return $self->_false unless @values;
14774be0 266
ef0d6124 267 return $self->_expr($field) .
9d7d0694 268 $not .
14774be0 269 " IN (" .
9d7d0694 270 join(", ", map { $self->dispatch($_) } @values ) .
14774be0 271 ")";
272 }
273
1f4bd99c 274 method _between(AST $ast) {
275
276 my ($field,@values) = @{$ast->{args}};
277
278 my $not = ($ast->{op} =~ /^not_/) ? " NOT" : "";
279 croak "between requires 3 arguments: " . dump($ast)
280 unless @values == 2;
281
282 return $self->_expr($field) .
283 $not .
284 " BETWEEN " .
285 join(" AND ", map { $self->dispatch($_) } @values );
286 }
287
44cfd1f6 288 # 'constants' that are portable across DBs
289 method _false($ast?) { "0 = 1" }
290 method _true($ast?) { "1 = 1" }
291
14774be0 292}