Commit | Line | Data |
01dd4e4f |
1 | package SQL::Abstract::Tree; |
2 | |
3 | use strict; |
4 | use warnings; |
b3b79607 |
5 | no warnings 'qw'; |
01dd4e4f |
6 | use Carp; |
7 | |
0769ac0e |
8 | use Hash::Merge qw//; |
9 | |
10 | use base 'Class::Accessor::Grouped'; |
11 | |
ad591616 |
12 | __PACKAGE__->mk_group_accessors( simple => qw( |
0769ac0e |
13 | newline indent_string indent_amount colormap indentmap fill_in_placeholders |
14 | placeholder_surround |
ad591616 |
15 | )); |
2fed0b4b |
16 | |
bc482085 |
17 | my $merger = Hash::Merge->new; |
18 | |
19 | $merger->specify_behavior({ |
2fed0b4b |
20 | SCALAR => { |
21 | SCALAR => sub { $_[1] }, |
22 | ARRAY => sub { [ $_[0], @{$_[1]} ] }, |
23 | HASH => sub { $_[1] }, |
24 | }, |
25 | ARRAY => { |
26 | SCALAR => sub { $_[1] }, |
27 | ARRAY => sub { $_[1] }, |
28 | HASH => sub { $_[1] }, |
29 | }, |
30 | HASH => { |
31 | SCALAR => sub { $_[1] }, |
32 | ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] }, |
33 | HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) }, |
34 | }, |
0769ac0e |
35 | }, 'SQLA::Tree Behavior' ); |
1536de15 |
36 | |
0769ac0e |
37 | my $op_look_ahead = '(?: (?= [\s\)\(\;] ) | \z)'; |
b3b79607 |
38 | my $op_look_behind = '(?: (?<= [\,\s\)\(] ) | \A )'; |
39 | |
0769ac0e |
40 | my $quote_left = qr/[\`\'\"\[]/; |
41 | my $quote_right = qr/[\`\'\"\]]/; |
01dd4e4f |
42 | |
4e914a7c |
43 | my $placeholder_re = qr/(?: \? | \$\d+ )/x; |
44 | |
01dd4e4f |
45 | # These SQL keywords always signal end of the current expression (except inside |
46 | # of a parenthesized subexpression). |
0769ac0e |
47 | # Format: A list of strings that will be compiled to extended syntax ie. |
01dd4e4f |
48 | # /.../x) regexes, without capturing parentheses. They will be automatically |
0769ac0e |
49 | # anchored to op boundaries (excluding quotes) to match the whole token. |
50 | my @expression_start_keywords = ( |
01dd4e4f |
51 | 'SELECT', |
7853a177 |
52 | 'UPDATE', |
6c4d8eb8 |
53 | 'SET', |
7853a177 |
54 | 'INSERT \s+ INTO', |
55 | 'DELETE \s+ FROM', |
3d910890 |
56 | 'FROM', |
01dd4e4f |
57 | '(?: |
58 | (?: |
0769ac0e |
59 | (?: (?: LEFT | RIGHT | FULL ) \s+ )? |
60 | (?: (?: CROSS | INNER | OUTER ) \s+ )? |
01dd4e4f |
61 | )? |
62 | JOIN |
63 | )', |
64 | 'ON', |
65 | 'WHERE', |
efc991a0 |
66 | '(?: DEFAULT \s+ )? VALUES', |
01dd4e4f |
67 | 'GROUP \s+ BY', |
68 | 'HAVING', |
69 | 'ORDER \s+ BY', |
c0eaa9fd |
70 | 'SKIP', |
71 | 'FIRST', |
01dd4e4f |
72 | 'LIMIT', |
73 | 'OFFSET', |
74 | 'FOR', |
75 | 'UNION', |
76 | 'INTERSECT', |
77 | 'EXCEPT', |
820bb1f5 |
78 | 'BEGIN \s+ WORK', |
79 | 'COMMIT', |
80 | 'ROLLBACK \s+ TO \s+ SAVEPOINT', |
81 | 'ROLLBACK', |
82 | 'SAVEPOINT', |
83 | 'RELEASE \s+ SAVEPOINT', |
01dd4e4f |
84 | 'RETURNING', |
8d0dd7dc |
85 | 'ROW_NUMBER \s* \( \s* \) \s+ OVER', |
01dd4e4f |
86 | ); |
87 | |
b3b79607 |
88 | my $expr_start_re = join ("\n\t|\n", @expression_start_keywords ); |
89 | $expr_start_re = qr/ $op_look_behind (?i: $expr_start_re ) $op_look_ahead /x; |
0769ac0e |
90 | |
01dd4e4f |
91 | # These are binary operator keywords always a single LHS and RHS |
92 | # * AND/OR are handled separately as they are N-ary |
93 | # * so is NOT as being unary |
94 | # * BETWEEN without paranthesis around the ANDed arguments (which |
95 | # makes it a non-binary op) is detected and accomodated in |
96 | # _recurse_parse() |
6c4d8eb8 |
97 | # * AS is not really an operator but is handled here as it's also LHS/RHS |
01dd4e4f |
98 | |
0769ac0e |
99 | # this will be included in the $binary_op_re, the distinction is interesting during |
100 | # testing as one is tighter than the other, plus mathops have different look |
101 | # ahead/behind (e.g. "x"="y" ) |
102 | my @math_op_keywords = (qw/ < > != <> = <= >= /); |
ad591616 |
103 | my $math_op_re = join ("\n\t|\n", map |
0769ac0e |
104 | { "(?: (?<= [\\w\\s] | $quote_right ) | \\A )" . quotemeta ($_) . "(?: (?= [\\w\\s] | $quote_left ) | \\z )" } |
105 | @math_op_keywords |
01dd4e4f |
106 | ); |
ad591616 |
107 | $math_op_re = qr/$math_op_re/x; |
0769ac0e |
108 | |
109 | my $binary_op_re = '(?: NOT \s+)? (?:' . join ('|', qw/IN BETWEEN R?LIKE/) . ')'; |
b3b79607 |
110 | $binary_op_re = join "\n\t|\n", |
6c4d8eb8 |
111 | "$op_look_behind (?i: $binary_op_re | AS ) $op_look_ahead", |
ad591616 |
112 | $math_op_re, |
b3b79607 |
113 | $op_look_behind . 'IS (?:\s+ NOT)?' . "(?= \\s+ NULL \\b | $op_look_ahead )", |
114 | ; |
b7b0f832 |
115 | $binary_op_re = qr/$binary_op_re/x; |
0769ac0e |
116 | |
6f2a5b66 |
117 | my $unary_op_re = '(?: NOT \s+ EXISTS | NOT )'; |
118 | $unary_op_re = join "\n\t|\n", |
119 | "$op_look_behind (?i: $unary_op_re ) $op_look_ahead", |
120 | ; |
121 | $unary_op_re = qr/$unary_op_re/x; |
122 | |
ad591616 |
123 | my $asc_desc_re = qr/$op_look_behind (?i: ASC | DESC ) $op_look_ahead /x; |
124 | my $and_or_re = qr/$op_look_behind (?i: AND | OR ) $op_look_ahead /x; |
6f2a5b66 |
125 | |
ad591616 |
126 | my $tokenizer_re = join("\n\t|\n", |
b3b79607 |
127 | $expr_start_re, |
0769ac0e |
128 | $binary_op_re, |
6f2a5b66 |
129 | $unary_op_re, |
ad591616 |
130 | $asc_desc_re, |
131 | $and_or_re, |
132 | "$op_look_behind \\* $op_look_ahead", |
257ecc8a |
133 | (map { quotemeta $_ } qw/, ( )/), |
4e914a7c |
134 | $placeholder_re, |
0769ac0e |
135 | ); |
01dd4e4f |
136 | |
ad591616 |
137 | # this one *is* capturing for the split below |
b3b79607 |
138 | # splits on whitespace if all else fails |
ad591616 |
139 | # has to happen before the composiign qr's are anchored (below) |
140 | $tokenizer_re = qr/ \s* ( $tokenizer_re ) \s* | \s+ /x; |
b3b79607 |
141 | |
142 | # Parser states for _recurse_parse() |
143 | use constant PARSE_TOP_LEVEL => 0; |
144 | use constant PARSE_IN_EXPR => 1; |
145 | use constant PARSE_IN_PARENS => 2; |
146 | use constant PARSE_IN_FUNC => 3; |
147 | use constant PARSE_RHS => 4; |
6f2a5b66 |
148 | use constant PARSE_LIST_ELT => 5; |
b3b79607 |
149 | |
ad591616 |
150 | my $expr_term_re = qr/$expr_start_re | \)/x; |
151 | my $rhs_term_re = qr/ $expr_term_re | $binary_op_re | $unary_op_re | $asc_desc_re | $and_or_re | \, /x; |
152 | my $common_single_args_re = qr/ \* | $placeholder_re /x; |
153 | my $all_std_keywords_re = qr/ $rhs_term_re | \( | $common_single_args_re /x; |
154 | |
155 | # anchor everything - even though keywords are separated by the tokenizer, leakage may occur |
156 | for ( |
157 | $quote_left, |
158 | $quote_right, |
159 | $placeholder_re, |
160 | $expr_start_re, |
161 | $math_op_re, |
162 | $binary_op_re, |
163 | $unary_op_re, |
164 | $asc_desc_re, |
165 | $and_or_re, |
166 | $expr_term_re, |
167 | $rhs_term_re, |
168 | $common_single_args_re, |
169 | $all_std_keywords_re, |
170 | ) { |
171 | $_ = qr/ \A $_ \z /x; |
172 | } |
173 | |
6f2a5b66 |
174 | |
01dd4e4f |
175 | |
7e5600e9 |
176 | my %indents = ( |
7853a177 |
177 | select => 0, |
178 | update => 0, |
179 | 'insert into' => 0, |
180 | 'delete from' => 0, |
3d910890 |
181 | from => 1, |
91916220 |
182 | where => 0, |
7853a177 |
183 | join => 1, |
184 | 'left join' => 1, |
185 | on => 2, |
2867f4f5 |
186 | having => 0, |
91916220 |
187 | 'group by' => 0, |
188 | 'order by' => 0, |
7853a177 |
189 | set => 1, |
190 | into => 1, |
91916220 |
191 | values => 1, |
c0eaa9fd |
192 | limit => 1, |
193 | offset => 1, |
194 | skip => 1, |
195 | first => 1, |
7e5600e9 |
196 | ); |
197 | |
75c3a063 |
198 | my %profiles = ( |
199 | console => { |
84c65032 |
200 | fill_in_placeholders => 1, |
9d11f0d4 |
201 | placeholder_surround => ['?/', ''], |
1536de15 |
202 | indent_string => ' ', |
75c3a063 |
203 | indent_amount => 2, |
1536de15 |
204 | newline => "\n", |
3be357b0 |
205 | colormap => {}, |
6d388c84 |
206 | indentmap => \%indents, |
aafbf833 |
207 | |
208 | eval { require Term::ANSIColor } |
209 | ? do { |
210 | my $c = \&Term::ANSIColor::color; |
6d388c84 |
211 | |
212 | my $red = [$c->('red') , $c->('reset')]; |
213 | my $cyan = [$c->('cyan') , $c->('reset')]; |
214 | my $green = [$c->('green') , $c->('reset')]; |
215 | my $yellow = [$c->('yellow') , $c->('reset')]; |
216 | my $blue = [$c->('blue') , $c->('reset')]; |
217 | my $magenta = [$c->('magenta'), $c->('reset')]; |
218 | my $b_o_w = [$c->('black on_white'), $c->('reset')]; |
aafbf833 |
219 | ( |
fb98df48 |
220 | placeholder_surround => [$c->('black on_magenta'), $c->('reset')], |
aafbf833 |
221 | colormap => { |
6d388c84 |
222 | 'begin work' => $b_o_w, |
223 | commit => $b_o_w, |
224 | rollback => $b_o_w, |
225 | savepoint => $b_o_w, |
226 | 'rollback to savepoint' => $b_o_w, |
227 | 'release savepoint' => $b_o_w, |
228 | |
229 | select => $red, |
230 | 'insert into' => $red, |
231 | update => $red, |
232 | 'delete from' => $red, |
233 | |
234 | set => $cyan, |
235 | from => $cyan, |
236 | |
237 | where => $green, |
238 | values => $yellow, |
239 | |
240 | join => $magenta, |
241 | 'left join' => $magenta, |
242 | on => $blue, |
243 | |
244 | 'group by' => $yellow, |
2867f4f5 |
245 | having => $yellow, |
6d388c84 |
246 | 'order by' => $yellow, |
247 | |
248 | skip => $green, |
249 | first => $green, |
250 | limit => $green, |
251 | offset => $green, |
aafbf833 |
252 | } |
253 | ); |
254 | } : (), |
3be357b0 |
255 | }, |
256 | console_monochrome => { |
84c65032 |
257 | fill_in_placeholders => 1, |
9d11f0d4 |
258 | placeholder_surround => ['?/', ''], |
3be357b0 |
259 | indent_string => ' ', |
260 | indent_amount => 2, |
261 | newline => "\n", |
262 | colormap => {}, |
6d388c84 |
263 | indentmap => \%indents, |
7e5600e9 |
264 | }, |
265 | html => { |
84c65032 |
266 | fill_in_placeholders => 1, |
9d11f0d4 |
267 | placeholder_surround => ['<span class="placeholder">', '</span>'], |
7e5600e9 |
268 | indent_string => ' ', |
269 | indent_amount => 2, |
270 | newline => "<br />\n", |
271 | colormap => { |
7853a177 |
272 | select => ['<span class="select">' , '</span>'], |
273 | 'insert into' => ['<span class="insert-into">' , '</span>'], |
274 | update => ['<span class="select">' , '</span>'], |
275 | 'delete from' => ['<span class="delete-from">' , '</span>'], |
c0eaa9fd |
276 | |
277 | set => ['<span class="set">', '</span>'], |
7853a177 |
278 | from => ['<span class="from">' , '</span>'], |
c0eaa9fd |
279 | |
280 | where => ['<span class="where">' , '</span>'], |
281 | values => ['<span class="values">', '</span>'], |
282 | |
7853a177 |
283 | join => ['<span class="join">' , '</span>'], |
c0eaa9fd |
284 | 'left join' => ['<span class="left-join">','</span>'], |
7853a177 |
285 | on => ['<span class="on">' , '</span>'], |
c0eaa9fd |
286 | |
7853a177 |
287 | 'group by' => ['<span class="group-by">', '</span>'], |
2867f4f5 |
288 | having => ['<span class="having">', '</span>'], |
7853a177 |
289 | 'order by' => ['<span class="order-by">', '</span>'], |
c0eaa9fd |
290 | |
291 | skip => ['<span class="skip">', '</span>'], |
292 | first => ['<span class="first">', '</span>'], |
293 | limit => ['<span class="limit">', '</span>'], |
294 | offset => ['<span class="offset">', '</span>'], |
820bb1f5 |
295 | |
296 | 'begin work' => ['<span class="begin-work">', '</span>'], |
297 | commit => ['<span class="commit">', '</span>'], |
298 | rollback => ['<span class="rollback">', '</span>'], |
299 | savepoint => ['<span class="savepoint">', '</span>'], |
300 | 'rollback to savepoint' => ['<span class="rollback-to-savepoint">', '</span>'], |
301 | 'release savepoint' => ['<span class="release-savepoint">', '</span>'], |
1536de15 |
302 | }, |
6d388c84 |
303 | indentmap => \%indents, |
75c3a063 |
304 | }, |
305 | none => { |
1536de15 |
306 | colormap => {}, |
307 | indentmap => {}, |
75c3a063 |
308 | }, |
309 | ); |
310 | |
311 | sub new { |
2fed0b4b |
312 | my $class = shift; |
313 | my $args = shift || {}; |
75c3a063 |
314 | |
315 | my $profile = delete $args->{profile} || 'none'; |
1c33db5d |
316 | |
317 | die "No such profile '$profile'!" unless exists $profiles{$profile}; |
318 | |
bc482085 |
319 | my $data = $merger->merge( $profiles{$profile}, $args ); |
75c3a063 |
320 | |
321 | bless $data, $class |
322 | } |
d695b0ad |
323 | |
01dd4e4f |
324 | sub parse { |
d695b0ad |
325 | my ($self, $s) = @_; |
01dd4e4f |
326 | |
327 | # tokenize string, and remove all optional whitespace |
328 | my $tokens = []; |
329 | foreach my $token (split $tokenizer_re, $s) { |
b3b79607 |
330 | push @$tokens, $token if ( |
331 | defined $token |
332 | and |
333 | length $token |
09931431 |
334 | and |
b3b79607 |
335 | $token =~ /\S/ |
336 | ); |
01dd4e4f |
337 | } |
6f2a5b66 |
338 | |
339 | return [ $self->_recurse_parse($tokens, PARSE_TOP_LEVEL) ]; |
01dd4e4f |
340 | } |
341 | |
342 | sub _recurse_parse { |
d695b0ad |
343 | my ($self, $tokens, $state) = @_; |
01dd4e4f |
344 | |
6f2a5b66 |
345 | my @left; |
01dd4e4f |
346 | while (1) { # left-associative parsing |
347 | |
6f2a5b66 |
348 | if ( ! @$tokens |
01dd4e4f |
349 | or |
6f2a5b66 |
350 | ($state == PARSE_IN_PARENS && $tokens->[0] eq ')') |
01dd4e4f |
351 | or |
6f2a5b66 |
352 | ($state == PARSE_IN_EXPR && $tokens->[0] =~ $expr_term_re ) |
0769ac0e |
353 | or |
6f2a5b66 |
354 | ($state == PARSE_RHS && $tokens->[0] =~ $rhs_term_re ) |
01dd4e4f |
355 | or |
ad591616 |
356 | ($state == PARSE_LIST_ELT && ( $tokens->[0] eq ',' or $tokens->[0] =~ $expr_term_re ) ) |
01dd4e4f |
357 | ) { |
6f2a5b66 |
358 | return @left; |
01dd4e4f |
359 | } |
360 | |
361 | my $token = shift @$tokens; |
362 | |
363 | # nested expression in () |
364 | if ($token eq '(' ) { |
6f2a5b66 |
365 | my @right = $self->_recurse_parse($tokens, PARSE_IN_PARENS); |
366 | $token = shift @$tokens or croak "missing closing ')' around block " . $self->unparse(\@right); |
367 | $token eq ')' or croak "unexpected token '$token' terminating block " . $self->unparse(\@right); |
368 | |
369 | push @left, [ '-PAREN' => \@right ]; |
370 | } |
371 | |
372 | # AND/OR |
ad591616 |
373 | elsif ($token =~ $and_or_re) { |
6f2a5b66 |
374 | my $op = uc $token; |
01dd4e4f |
375 | |
6f2a5b66 |
376 | my @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR); |
377 | |
378 | # Merge chunks if "logic" matches |
379 | @left = [ $op => [ @left, (@right and $op eq $right[0][0]) |
380 | ? @{ $right[0][1] } |
381 | : @right |
382 | ] ]; |
01dd4e4f |
383 | } |
b3b79607 |
384 | |
6f2a5b66 |
385 | # LIST (,) |
386 | elsif ($token eq ',') { |
387 | |
388 | my @right = $self->_recurse_parse($tokens, PARSE_LIST_ELT); |
389 | |
390 | # deal with malformed lists ( foo, bar, , baz ) |
391 | @right = [] unless @right; |
01dd4e4f |
392 | |
6f2a5b66 |
393 | @right = [ -MISC => [ @right ] ] if @right > 1; |
394 | |
395 | if (!@left) { |
396 | @left = [ -LIST => [ [], @right ] ]; |
397 | } |
398 | elsif ($left[0][0] eq '-LIST') { |
399 | push @{$left[0][1]}, (@{$right[0]} and $right[0][0] eq '-LIST') |
400 | ? @{$right[0][1]} |
401 | : @right |
402 | ; |
01dd4e4f |
403 | } |
404 | else { |
6f2a5b66 |
405 | @left = [ -LIST => [ @left, @right ] ]; |
01dd4e4f |
406 | } |
407 | } |
6f2a5b66 |
408 | |
01dd4e4f |
409 | # binary operator keywords |
6f2a5b66 |
410 | elsif ($token =~ $binary_op_re) { |
01dd4e4f |
411 | my $op = uc $token; |
6f2a5b66 |
412 | |
413 | my @right = $self->_recurse_parse($tokens, PARSE_RHS); |
01dd4e4f |
414 | |
415 | # A between with a simple LITERAL for a 1st RHS argument needs a |
416 | # rerun of the search to (hopefully) find the proper AND construct |
6f2a5b66 |
417 | if ($op eq 'BETWEEN' and $right[0] eq '-LITERAL') { |
418 | unshift @$tokens, $right[1][0]; |
419 | @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR); |
01dd4e4f |
420 | } |
421 | |
6f2a5b66 |
422 | @left = [$op => [ @left, @right ]]; |
01dd4e4f |
423 | } |
6f2a5b66 |
424 | |
425 | # unary op keywords |
426 | elsif ( $token =~ $unary_op_re ) { |
01dd4e4f |
427 | my $op = uc $token; |
6f2a5b66 |
428 | my @right = $self->_recurse_parse ($tokens, PARSE_RHS); |
429 | |
430 | push @left, [ $op => \@right ]; |
01dd4e4f |
431 | } |
6f2a5b66 |
432 | |
433 | # expression terminator keywords |
434 | elsif ( $token =~ $expr_start_re ) { |
01dd4e4f |
435 | my $op = uc $token; |
6f2a5b66 |
436 | my @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR); |
01dd4e4f |
437 | |
6f2a5b66 |
438 | push @left, [ $op => \@right ]; |
01dd4e4f |
439 | } |
6f2a5b66 |
440 | |
441 | # a '?' |
4e914a7c |
442 | elsif ( $token =~ $placeholder_re) { |
6f2a5b66 |
443 | push @left, [ -PLACEHOLDER => [ $token ] ]; |
444 | } |
445 | |
446 | # check if the current token is an unknown op-start |
ad591616 |
447 | elsif (@$tokens and ($tokens->[0] eq '(' or $tokens->[0] =~ $common_single_args_re ) ) { |
6f2a5b66 |
448 | push @left, [ $token => [ $self->_recurse_parse($tokens, PARSE_RHS) ] ]; |
4e914a7c |
449 | } |
6f2a5b66 |
450 | |
b3b79607 |
451 | # we're now in "unknown token" land - start eating tokens until |
452 | # we see something familiar |
01dd4e4f |
453 | else { |
6f2a5b66 |
454 | my @lits = [ -LITERAL => [$token] ]; |
b3b79607 |
455 | |
6f2a5b66 |
456 | while (@$tokens and $tokens->[0] !~ $all_std_keywords_re) { |
457 | push @lits, [ -LITERAL => [ shift @$tokens ] ]; |
458 | } |
459 | |
460 | if (@left == 1) { |
461 | unshift @lits, pop @left; |
462 | } |
463 | |
464 | @lits = [ -MISC => [ @lits ] ] if @lits > 1; |
465 | |
466 | push @left, @lits; |
467 | } |
b3b79607 |
468 | |
6f2a5b66 |
469 | # deal with post-fix operators (only when sql is sane - i.e. we have one element to apply to) |
470 | if (@left == 1 and @$tokens) { |
471 | |
472 | # asc/desc |
473 | if ($tokens->[0] =~ $asc_desc_re) { |
474 | my $op = shift @$tokens; |
475 | |
476 | # if -MISC - this is a literal collection, do not promote asc/desc to an op |
477 | if ($left[0][0] eq '-MISC') { |
478 | push @{$left[0][1]}, [ -LITERAL => [ $op ] ]; |
479 | } |
480 | else { |
481 | @left = [ ('-' . uc ($op)) => [ @left ] ]; |
482 | } |
483 | } |
01dd4e4f |
484 | } |
485 | } |
486 | } |
487 | |
d695b0ad |
488 | sub format_keyword { |
489 | my ($self, $keyword) = @_; |
490 | |
1536de15 |
491 | if (my $around = $self->colormap->{lc $keyword}) { |
d695b0ad |
492 | $keyword = "$around->[0]$keyword$around->[1]"; |
493 | } |
494 | |
495 | return $keyword |
496 | } |
497 | |
728f26a2 |
498 | my %starters = ( |
499 | select => 1, |
500 | update => 1, |
501 | 'insert into' => 1, |
502 | 'delete from' => 1, |
503 | ); |
504 | |
f2ab166a |
505 | sub pad_keyword { |
a24cc3a0 |
506 | my ($self, $keyword, $depth) = @_; |
e171c446 |
507 | |
508 | my $before = ''; |
1536de15 |
509 | if (defined $self->indentmap->{lc $keyword}) { |
510 | $before = $self->newline . $self->indent($depth + $self->indentmap->{lc $keyword}); |
a24cc3a0 |
511 | } |
728f26a2 |
512 | $before = '' if $depth == 0 and defined $starters{lc $keyword}; |
e4570c8e |
513 | return [$before, '']; |
a24cc3a0 |
514 | } |
515 | |
1536de15 |
516 | sub indent { ($_[0]->indent_string||'') x ( ( $_[0]->indent_amount || 0 ) * $_[1] ) } |
a24cc3a0 |
517 | |
a97eb57c |
518 | sub _is_key { |
519 | my ($self, $tree) = @_; |
0569a14f |
520 | $tree = $tree->[0] while ref $tree; |
521 | |
a97eb57c |
522 | defined $tree && defined $self->indentmap->{lc $tree}; |
0569a14f |
523 | } |
524 | |
9d11f0d4 |
525 | sub fill_in_placeholder { |
fb272e73 |
526 | my ($self, $bindargs) = @_; |
527 | |
528 | if ($self->fill_in_placeholders) { |
ad46269d |
529 | my $val = shift @{$bindargs} || ''; |
4712657d |
530 | my $quoted = $val =~ s/^(['"])(.*)\1$/$2/; |
9d11f0d4 |
531 | my ($left, $right) = @{$self->placeholder_surround}; |
fb272e73 |
532 | $val =~ s/\\/\\\\/g; |
533 | $val =~ s/'/\\'/g; |
4712657d |
534 | $val = qq('$val') if $quoted; |
535 | return qq($left$val$right) |
fb272e73 |
536 | } |
537 | return '?' |
538 | } |
539 | |
3a247d23 |
540 | # FIXME - terrible name for a user facing API |
01dd4e4f |
541 | sub unparse { |
3a247d23 |
542 | my ($self, $tree, $bindargs) = @_; |
543 | $self->_unparse($tree, [@{$bindargs||[]}], 0); |
544 | } |
a24cc3a0 |
545 | |
3a247d23 |
546 | sub _unparse { |
547 | my ($self, $tree, $bindargs, $depth) = @_; |
01dd4e4f |
548 | |
0769ac0e |
549 | if (not $tree or not @$tree) { |
01dd4e4f |
550 | return ''; |
551 | } |
a24cc3a0 |
552 | |
007f0853 |
553 | # FIXME - needs a config switch to disable |
c01ac648 |
554 | $self->_parenthesis_unroll($tree); |
007f0853 |
555 | |
6f2a5b66 |
556 | my ($op, $args) = @{$tree}[0,1]; |
0769ac0e |
557 | |
6f2a5b66 |
558 | if (! defined $op or (! ref $op and ! defined $args) ) { |
0769ac0e |
559 | require Data::Dumper; |
560 | Carp::confess( sprintf ( "Internal error - malformed branch at depth $depth:\n%s", |
561 | Data::Dumper::Dumper($tree) |
562 | ) ); |
563 | } |
a24cc3a0 |
564 | |
6f2a5b66 |
565 | if (ref $op) { |
3a247d23 |
566 | return join (' ', map $self->_unparse($_, $bindargs, $depth), @$tree); |
01dd4e4f |
567 | } |
6f2a5b66 |
568 | elsif ($op eq '-LITERAL') { # literal has different sig |
569 | return $args->[0]; |
01dd4e4f |
570 | } |
6f2a5b66 |
571 | elsif ($op eq '-PLACEHOLDER') { |
4e914a7c |
572 | return $self->fill_in_placeholder($bindargs); |
573 | } |
6f2a5b66 |
574 | elsif ($op eq '-PAREN') { |
c4d7cfcf |
575 | return sprintf ('( %s )', |
6f2a5b66 |
576 | join (' ', map { $self->_unparse($_, $bindargs, $depth + 2) } @{$args} ) |
e4570c8e |
577 | . |
6f2a5b66 |
578 | ($self->_is_key($args) |
e4570c8e |
579 | ? ( $self->newline||'' ) . $self->indent($depth + 1) |
580 | : '' |
581 | ) |
582 | ); |
01dd4e4f |
583 | } |
ad591616 |
584 | elsif ($op eq 'AND' or $op eq 'OR' or $op =~ $binary_op_re ) { |
6f2a5b66 |
585 | return join (" $op ", map $self->_unparse($_, $bindargs, $depth), @{$args}); |
586 | } |
587 | elsif ($op eq '-LIST' ) { |
588 | return join (', ', map $self->_unparse($_, $bindargs, $depth), @{$args}); |
01dd4e4f |
589 | } |
6f2a5b66 |
590 | elsif ($op eq '-MISC' ) { |
591 | return join (' ', map $self->_unparse($_, $bindargs, $depth), @{$args}); |
b3b79607 |
592 | } |
01dd4e4f |
593 | else { |
6f2a5b66 |
594 | my ($l, $r) = @{$self->pad_keyword($op, $depth)}; |
c4d7cfcf |
595 | return sprintf "$l%s%s%s$r", |
6f2a5b66 |
596 | $self->format_keyword($op), |
597 | ( ref $args eq 'ARRAY' and @{$args} == 1 and $args->[0][0] eq '-PAREN' ) |
c4d7cfcf |
598 | ? '' # mysql-- |
599 | : ' ' |
600 | , |
6f2a5b66 |
601 | $self->_unparse($args, $bindargs, $depth), |
c4d7cfcf |
602 | ; |
01dd4e4f |
603 | } |
604 | } |
605 | |
bb54fcb4 |
606 | # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics |
607 | my @unrollable_ops = ( |
608 | 'ON', |
609 | 'WHERE', |
610 | 'GROUP \s+ BY', |
611 | 'HAVING', |
612 | 'ORDER \s+ BY', |
6e9a377b |
613 | 'I?LIKE', |
bb54fcb4 |
614 | ); |
615 | my $unrollable_ops_re = join ' | ', @unrollable_ops; |
616 | $unrollable_ops_re = qr/$unrollable_ops_re/xi; |
617 | |
618 | sub _parenthesis_unroll { |
619 | my $self = shift; |
620 | my $ast = shift; |
621 | |
bb54fcb4 |
622 | return unless (ref $ast and ref $ast->[1]); |
623 | |
624 | my $changes; |
625 | do { |
626 | my @children; |
627 | $changes = 0; |
628 | |
629 | for my $child (@{$ast->[1]}) { |
007f0853 |
630 | |
bb54fcb4 |
631 | # the current node in this loop is *always* a PAREN |
6f2a5b66 |
632 | if (! ref $child or ! @$child or $child->[0] ne '-PAREN') { |
bb54fcb4 |
633 | push @children, $child; |
634 | next; |
635 | } |
636 | |
637 | # unroll nested parenthesis |
6f2a5b66 |
638 | while ( @{$child->[1]} == 1 and $child->[1][0][0] eq '-PAREN') { |
bb54fcb4 |
639 | $child = $child->[1][0]; |
640 | $changes++; |
641 | } |
642 | |
6f2a5b66 |
643 | # if the parent operator explcitly allows it nuke the parenthesis |
644 | if ( $ast->[0] =~ $unrollable_ops_re ) { |
645 | push @children, @{$child->[1]}; |
646 | $changes++; |
647 | } |
648 | |
bb54fcb4 |
649 | # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list |
6f2a5b66 |
650 | elsif ( |
651 | @{$child->[1]} == 1 |
652 | and |
bb54fcb4 |
653 | ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR') |
654 | and |
6f2a5b66 |
655 | $child->[1][0][0] eq $ast->[0] |
bb54fcb4 |
656 | ) { |
657 | push @children, @{$child->[1][0][1]}; |
658 | $changes++; |
659 | } |
660 | |
bb54fcb4 |
661 | # only *ONE* LITERAL or placeholder element |
6e9a377b |
662 | # as an AND/OR/NOT argument |
bb54fcb4 |
663 | elsif ( |
664 | @{$child->[1]} == 1 && ( |
6f2a5b66 |
665 | $child->[1][0][0] eq '-LITERAL' |
bb54fcb4 |
666 | or |
6f2a5b66 |
667 | $child->[1][0][0] eq '-PLACEHOLDER' |
6e9a377b |
668 | ) && ( |
669 | $ast->[0] eq 'AND' or $ast->[0] eq 'OR' or $ast->[0] eq 'NOT' |
bb54fcb4 |
670 | ) |
671 | ) { |
6f2a5b66 |
672 | push @children, @{$child->[1]}; |
bb54fcb4 |
673 | $changes++; |
674 | } |
675 | |
007f0853 |
676 | # an AND/OR expression with only one binop in the parenthesis |
677 | # with exactly two grandchildren |
bb54fcb4 |
678 | # the only time when we can *not* unroll this is when both |
679 | # the parent and the child are mathops (in which case we'll |
680 | # break precedence) or when the child is BETWEEN (special |
681 | # case) |
682 | elsif ( |
683 | @{$child->[1]} == 1 |
684 | and |
007f0853 |
685 | ($ast->[0] eq 'AND' or $ast->[0] eq 'OR') |
686 | and |
ad591616 |
687 | $child->[1][0][0] =~ $binary_op_re |
bb54fcb4 |
688 | and |
689 | $child->[1][0][0] ne 'BETWEEN' |
690 | and |
691 | @{$child->[1][0][1]} == 2 |
692 | and |
693 | ! ( |
ad591616 |
694 | $child->[1][0][0] =~ $math_op_re |
bb54fcb4 |
695 | and |
ad591616 |
696 | $ast->[0] =~ $math_op_re |
bb54fcb4 |
697 | ) |
698 | ) { |
6f2a5b66 |
699 | push @children, @{$child->[1]}; |
bb54fcb4 |
700 | $changes++; |
701 | } |
702 | |
703 | # a function binds tighter than a mathop - see if our ancestor is a |
704 | # mathop, and our content is: |
705 | # a single non-mathop child with a single PAREN grandchild which |
706 | # would indicate mathop ( nonmathop ( ... ) ) |
707 | # or a single non-mathop with a single LITERAL ( nonmathop foo ) |
708 | # or a single non-mathop with a single PLACEHOLDER ( nonmathop ? ) |
709 | elsif ( |
710 | @{$child->[1]} == 1 |
711 | and |
712 | @{$child->[1][0][1]} == 1 |
713 | and |
ad591616 |
714 | $ast->[0] =~ $math_op_re |
bb54fcb4 |
715 | and |
ad591616 |
716 | $child->[1][0][0] !~ $math_op_re |
bb54fcb4 |
717 | and |
718 | ( |
6f2a5b66 |
719 | $child->[1][0][1][0][0] eq '-PAREN' |
bb54fcb4 |
720 | or |
6f2a5b66 |
721 | $child->[1][0][1][0][0] eq '-LITERAL' |
bb54fcb4 |
722 | or |
6f2a5b66 |
723 | $child->[1][0][1][0][0] eq '-PLACEHOLDER' |
bb54fcb4 |
724 | ) |
725 | ) { |
6f2a5b66 |
726 | push @children, @{$child->[1]}; |
bb54fcb4 |
727 | $changes++; |
728 | } |
729 | |
730 | |
731 | # otherwise no more mucking for this pass |
732 | else { |
733 | push @children, $child; |
734 | } |
735 | } |
736 | |
737 | $ast->[1] = \@children; |
738 | |
739 | } while ($changes); |
bb54fcb4 |
740 | } |
741 | |
fb272e73 |
742 | sub format { my $self = shift; $self->unparse($self->parse($_[0]), $_[1]) } |
01dd4e4f |
743 | |
744 | 1; |
745 | |
3be357b0 |
746 | =pod |
747 | |
b912ee1e |
748 | =head1 NAME |
749 | |
750 | SQL::Abstract::Tree - Represent SQL as an AST |
751 | |
3be357b0 |
752 | =head1 SYNOPSIS |
753 | |
754 | my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' }); |
755 | |
756 | print $sqla_tree->format('SELECT * FROM foo WHERE foo.a > 2'); |
757 | |
758 | # SELECT * |
759 | # FROM foo |
760 | # WHERE foo.a > 2 |
761 | |
6b1bf9f8 |
762 | =head1 METHODS |
763 | |
764 | =head2 new |
765 | |
766 | my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' }); |
767 | |
c22f502d |
768 | $args = { |
769 | profile => 'console', # predefined profile to use (default: 'none') |
770 | fill_in_placeholders => 1, # true for placeholder population |
9d11f0d4 |
771 | placeholder_surround => # The strings that will be wrapped around |
772 | [GREEN, RESET], # populated placeholders if the above is set |
c22f502d |
773 | indent_string => ' ', # the string used when indenting |
774 | indent_amount => 2, # how many of above string to use for a single |
775 | # indent level |
776 | newline => "\n", # string for newline |
777 | colormap => { |
778 | select => [RED, RESET], # a pair of strings defining what to surround |
779 | # the keyword with for colorization |
780 | # ... |
781 | }, |
782 | indentmap => { |
783 | select => 0, # A zero means that the keyword will start on |
784 | # a new line |
785 | from => 1, # Any other positive integer means that after |
786 | on => 2, # said newline it will get that many indents |
787 | # ... |
788 | }, |
789 | } |
790 | |
791 | Returns a new SQL::Abstract::Tree object. All arguments are optional. |
792 | |
793 | =head3 profiles |
794 | |
795 | There are four predefined profiles, C<none>, C<console>, C<console_monochrome>, |
796 | and C<html>. Typically a user will probably just use C<console> or |
797 | C<console_monochrome>, but if something about a profile bothers you, merely |
798 | use the profile and override the parts that you don't like. |
799 | |
6b1bf9f8 |
800 | =head2 format |
801 | |
c22f502d |
802 | $sqlat->format('SELECT * FROM bar WHERE x = ?', [1]) |
803 | |
804 | Takes C<$sql> and C<\@bindargs>. |
6b1bf9f8 |
805 | |
1a3cc911 |
806 | Returns a formatting string based on the string passed in |
ee4227a7 |
807 | |
808 | =head2 parse |
809 | |
810 | $sqlat->parse('SELECT * FROM bar WHERE x = ?') |
811 | |
812 | Returns a "tree" representing passed in SQL. Please do not depend on the |
813 | structure of the returned tree. It may be stable at some point, but not yet. |
814 | |
815 | =head2 unparse |
816 | |
90d0250b |
817 | $sqlat->unparse($tree_structure, \@bindargs) |
ee4227a7 |
818 | |
819 | Transform "tree" into SQL, applying various transforms on the way. |
820 | |
821 | =head2 format_keyword |
822 | |
823 | $sqlat->format_keyword('SELECT') |
824 | |
825 | Currently this just takes a keyword and puts the C<colormap> stuff around it. |
826 | Later on it may do more and allow for coderef based transforms. |
827 | |
f2ab166a |
828 | =head2 pad_keyword |
ee4227a7 |
829 | |
f2ab166a |
830 | my ($before, $after) = @{$sqlat->pad_keyword('SELECT')}; |
ee4227a7 |
831 | |
832 | Returns whitespace to be inserted around a keyword. |
9d11f0d4 |
833 | |
834 | =head2 fill_in_placeholder |
835 | |
836 | my $value = $sqlat->fill_in_placeholder(\@bindargs) |
837 | |
838 | Removes last arg from passed arrayref and returns it, surrounded with |
839 | the values in placeholder_surround, and then surrounded with single quotes. |
f2ab166a |
840 | |
841 | =head2 indent |
842 | |
843 | Returns as many indent strings as indent amounts times the first argument. |
844 | |
845 | =head1 ACCESSORS |
846 | |
847 | =head2 colormap |
848 | |
849 | See L</new> |
850 | |
851 | =head2 fill_in_placeholders |
852 | |
853 | See L</new> |
854 | |
855 | =head2 indent_amount |
856 | |
857 | See L</new> |
858 | |
859 | =head2 indent_string |
860 | |
861 | See L</new> |
862 | |
863 | =head2 indentmap |
864 | |
865 | See L</new> |
866 | |
867 | =head2 newline |
868 | |
869 | See L</new> |
870 | |
871 | =head2 placeholder_surround |
872 | |
873 | See L</new> |
874 | |