lib/SQL/Abstract/Tree.pm

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