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