lib/SQL/Abstract/Tree.pm

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