lib/SQL/Abstract/Tree.pm

   1 package SQL::Abstract::Tree;
   2
   3 use strict;
   4 use warnings;
   5 use Carp;
   6
   7 # Parser states for _recurse_parse()
   8 use constant PARSE_TOP_LEVEL => 0;
   9 use constant PARSE_IN_EXPR => 1;
  10 use constant PARSE_IN_PARENS => 2;
  11 use constant PARSE_RHS => 3;
  12
  13 # These SQL keywords always signal end of the current expression (except inside
  14 # of a parenthesized subexpression).
  15 # Format: A list of strings that will be compiled to extended syntax (ie.
  16 # /.../x) regexes, without capturing parentheses. They will be automatically
  17 # anchored to word boundaries to match the whole token).
  18 my @expression_terminator_sql_keywords = (
  19   'SELECT',
  20   'FROM',
  21   '(?:
  22     (?:
  23         (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
  24         (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
  25     )?
  26     JOIN
  27   )',
  28   'ON',
  29   'WHERE',
  30   'EXISTS',
  31   'GROUP \s+ BY',
  32   'HAVING',
  33   'ORDER \s+ BY',
  34   'LIMIT',
  35   'OFFSET',
  36   'FOR',
  37   'UNION',
  38   'INTERSECT',
  39   'EXCEPT',
  40   'RETURNING',
  41 );
  42
  43 # These are binary operator keywords always a single LHS and RHS
  44 # * AND/OR are handled separately as they are N-ary
  45 # * so is NOT as being unary
  46 # * BETWEEN without paranthesis around the ANDed arguments (which
  47 #   makes it a non-binary op) is detected and accomodated in
  48 #   _recurse_parse()
  49 my $stuff_around_mathops = qr/[\w\s\`\'\"\)]/;
  50 my @binary_op_keywords = (
  51   ( map
  52     {
  53       ' ^ '  . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
  54       " (?<= $stuff_around_mathops)" . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
  55     }
  56     (qw/< > != <> = <= >=/)
  57   ),
  58   ( map
  59     { '\b (?: NOT \s+)?' . $_ . '\b' }
  60     (qw/IN BETWEEN LIKE/)
  61   ),
  62 );
  63
  64 my $tokenizer_re_str = join("\n\t|\n",
  65   ( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR', 'NOT'),
  66   @binary_op_keywords,
  67 );
  68
  69 my $tokenizer_re = qr/ \s* ( $tokenizer_re_str | \( | \) | \? ) \s* /xi;
  70
  71 sub _binary_op_keywords { @binary_op_keywords }
  72
  73 my %profiles = (
  74    console => {
  75       indent => ' ',
  76       indent_amount => 2,
  77       newline => "\n",
  78    },
  79    none => {
  80       indent => '',
  81       indent_amount => 0,
  82       newline => '',
  83    },
  84 );
  85
  86 sub new {
  87    my ($class, $args) = @_;
  88
  89    my $profile = delete $args->{profile} || 'none';
  90    my $data = {%{$profiles{$profile}}, %{$args||{}}};
  91
  92    bless $data, $class
  93 }
  94
  95 sub parse {
  96   my ($self, $s) = @_;
  97
  98   # tokenize string, and remove all optional whitespace
  99   my $tokens = [];
 100   foreach my $token (split $tokenizer_re, $s) {
 101     push @$tokens, $token if (length $token) && ($token =~ /\S/);
 102   }
 103
 104   my $tree = $self->_recurse_parse($tokens, PARSE_TOP_LEVEL);
 105   return $tree;
 106 }
 107
 108 sub _recurse_parse {
 109   my ($self, $tokens, $state) = @_;
 110
 111   my $left;
 112   while (1) { # left-associative parsing
 113
 114     my $lookahead = $tokens->[0];
 115     if ( not defined($lookahead)
 116           or
 117         ($state == PARSE_IN_PARENS && $lookahead eq ')')
 118           or
 119         ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords ) )
 120           or
 121         ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords, @binary_op_keywords, 'AND', 'OR', 'NOT' ) )
 122     ) {
 123       return $left;
 124     }
 125
 126     my $token = shift @$tokens;
 127
 128     # nested expression in ()
 129     if ($token eq '(' ) {
 130       my $right = $self->_recurse_parse($tokens, PARSE_IN_PARENS);
 131       $token = shift @$tokens   or croak "missing closing ')' around block " . $self->unparse($right);
 132       $token eq ')'             or croak "unexpected token '$token' terminating block " . $self->unparse($right);
 133
 134       $left = $left ? [@$left, [PAREN => [$right] ]]
 135                     : [PAREN  => [$right] ];
 136     }
 137     # AND/OR
 138     elsif ($token =~ /^ (?: OR | AND ) $/xi )  {
 139       my $op = uc $token;
 140       my $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
 141
 142       # Merge chunks if logic matches
 143       if (ref $right and $op eq $right->[0]) {
 144         $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
 145       }
 146       else {
 147        $left = [$op => [$left, $right]];
 148       }
 149     }
 150     # binary operator keywords
 151     elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
 152       my $op = uc $token;
 153       my $right = $self->_recurse_parse($tokens, PARSE_RHS);
 154
 155       # A between with a simple LITERAL for a 1st RHS argument needs a
 156       # rerun of the search to (hopefully) find the proper AND construct
 157       if ($op eq 'BETWEEN' and $right->[0] eq 'LITERAL') {
 158         unshift @$tokens, $right->[1][0];
 159         $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
 160       }
 161
 162       $left = [$op => [$left, $right] ];
 163     }
 164     # expression terminator keywords (as they start a new expression)
 165     elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
 166       my $op = uc $token;
 167       my $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
 168       $left = $left ? [ $left,  [$op => [$right] ]]
 169                     : [ $op => [$right] ];
 170     }
 171     # NOT (last as to allow all other NOT X pieces first)
 172     elsif ( $token =~ /^ not $/ix ) {
 173       my $op = uc $token;
 174       my $right = $self->_recurse_parse ($tokens, PARSE_RHS);
 175       $left = $left ? [ @$left, [$op => [$right] ]]
 176                     : [ $op => [$right] ];
 177
 178     }
 179     # literal (eat everything on the right until RHS termination)
 180     else {
 181       my $right = $self->_recurse_parse ($tokens, PARSE_RHS);
 182       $left = $left ? [ $left, [LITERAL => [join ' ', $token, $self->unparse($right)||()] ] ]
 183                     : [ LITERAL => [join ' ', $token, $self->unparse($right)||()] ];
 184     }
 185   }
 186 }
 187
 188 use Term::ANSIColor 'color';
 189
 190 my %ghetto_colormap = (
 191   select => [color('red'), color('reset')],
 192   where => [color('green'), color('reset')],
 193   from => [color('cyan'), color('reset')],
 194 );
 195
 196 sub format_keyword {
 197   my ($self, $keyword) = @_;
 198
 199   if (my $around = $ghetto_colormap{lc $keyword}) {
 200      $keyword = "$around->[0]$keyword$around->[1]";
 201   }
 202
 203   return $keyword
 204 }
 205
 206
 207 my %ghetto_whitespacemap = (
 208   select => 0,
 209   where  => 1,
 210   from   => 1,
 211 );
 212
 213 sub whitespace {
 214    my ($self, $keyword, $depth) = @_;
 215
 216    my $before = '';
 217    my $after  = '';
 218    if (defined $ghetto_whitespacemap{lc $keyword}) {
 219       $before = $self->newline . $self->indent($depth + $ghetto_whitespacemap{lc $keyword});
 220    }
 221    $before = '' if $depth == 0 and lc $keyword eq 'select';
 222    return [$before, $after];
 223 }
 224
 225 sub _newline { $_[0]->{newline} }
 226 sub _indent { $_[0]->{indent} }
 227 sub _indent_amount { $_[0]->{indent_amount} }
 228 sub newline { $_[0]->_newline }
 229
 230 sub indent { $_[0]->_indent x $_[0]->_indent_amount x $_[1] }
 231
 232 sub _is_select {
 233    my $tree = shift;
 234    $tree = $tree->[0] while ref $tree;
 235
 236    defined $tree && lc $tree eq 'select';
 237 }
 238
 239 sub unparse {
 240   my ($self, $tree, $depth) = @_;
 241
 242   $depth ||= 0;
 243
 244   if (not $tree ) {
 245     return '';
 246   }
 247
 248   my $car = $tree->[0];
 249   my $cdr = $tree->[1];
 250
 251   if (ref $car) {
 252     return join ('', map $self->unparse($_, $depth), @$tree);
 253   }
 254   elsif ($car eq 'LITERAL') {
 255     return $cdr->[0];
 256   }
 257   elsif ($car eq 'PAREN') {
 258     return '(' .
 259       join(' ',
 260         map $self->unparse($_, $depth + 2), @{$cdr}) .
 261     (_is_select($cdr)?$self->newline.$self->indent($depth + 1):'') . ')';
 262   }
 263   elsif ($car eq 'OR' or $car eq 'AND' or (grep { $car =~ /^ $_ $/xi } @binary_op_keywords ) ) {
 264     return join (" $car ", map $self->unparse($_, $depth), @{$cdr});
 265   }
 266   else {
 267     my ($l, $r) = @{$self->whitespace($car, $depth)};
 268     return sprintf "$l%s %s$r", $self->format_keyword($car), $self->unparse($cdr, $depth);
 269   }
 270 }
 271
 272 sub format { my $self = shift; $self->unparse($self->parse(@_)) }
 273
 274 1;
 275