lib/SQL/Abstract/Tree.pm

   1 package SQL::Abstract::Tree;
   2
   3 use strict;
   4 use warnings;
   5 use Carp;
   6
   7 use List::Util;
   8 use Hash::Merge 'merge';
   9
  10 Hash::Merge::specify_behavior({
  11    SCALAR => {
  12       SCALAR => sub { $_[1] },
  13       ARRAY  => sub { [ $_[0], @{$_[1]} ] },
  14       HASH   => sub { $_[1] },
  15    },
  16    ARRAY => {
  17       SCALAR => sub { $_[1] },
  18       ARRAY  => sub { $_[1] },
  19       HASH   => sub { $_[1] },
  20    },
  21    HASH => {
  22       SCALAR => sub { $_[1] },
  23       ARRAY  => sub { [ values %{$_[0]}, @{$_[1]} ] },
  24       HASH   => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) },
  25    },
  26 }, 'My Behavior' );
  27
  28 use base 'Class::Accessor::Grouped';
  29
  30 __PACKAGE__->mk_group_accessors( simple => $_ ) for qw(
  31    newline indent_string indent_amount colormap indentmap fill_in_placeholders
  32    include_caller caller_depth
  33 );
  34
  35 # Parser states for _recurse_parse()
  36 use constant PARSE_TOP_LEVEL => 0;
  37 use constant PARSE_IN_EXPR => 1;
  38 use constant PARSE_IN_PARENS => 2;
  39 use constant PARSE_RHS => 3;
  40
  41 # These SQL keywords always signal end of the current expression (except inside
  42 # of a parenthesized subexpression).
  43 # Format: A list of strings that will be compiled to extended syntax (ie.
  44 # /.../x) regexes, without capturing parentheses. They will be automatically
  45 # anchored to word boundaries to match the whole token).
  46 my @expression_terminator_sql_keywords = (
  47   'SELECT',
  48   'UPDATE',
  49   'INSERT \s+ INTO',
  50   'DELETE \s+ FROM',
  51   'FROM',
  52   'SET',
  53   '(?:
  54     (?:
  55         (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
  56         (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
  57     )?
  58     JOIN
  59   )',
  60   'ON',
  61   'WHERE',
  62   'VALUES',
  63   'EXISTS',
  64   'GROUP \s+ BY',
  65   'HAVING',
  66   'ORDER \s+ BY',
  67   'LIMIT',
  68   'OFFSET',
  69   'FOR',
  70   'UNION',
  71   'INTERSECT',
  72   'EXCEPT',
  73   'RETURNING',
  74   'ROW_NUMBER \s* \( \s* \) \s+ OVER',
  75 );
  76
  77 # These are binary operator keywords always a single LHS and RHS
  78 # * AND/OR are handled separately as they are N-ary
  79 # * so is NOT as being unary
  80 # * BETWEEN without paranthesis around the ANDed arguments (which
  81 #   makes it a non-binary op) is detected and accomodated in
  82 #   _recurse_parse()
  83 my $stuff_around_mathops = qr/[\w\s\`\'\"\)]/;
  84 my @binary_op_keywords = (
  85   ( map
  86     {
  87       ' ^ '  . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
  88       " (?<= $stuff_around_mathops)" . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
  89     }
  90     (qw/< > != <> = <= >=/)
  91   ),
  92   ( map
  93     { '\b (?: NOT \s+)?' . $_ . '\b' }
  94     (qw/IN BETWEEN LIKE/)
  95   ),
  96 );
  97
  98 my $tokenizer_re_str = join("\n\t|\n",
  99   ( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR', 'NOT'),
 100   @binary_op_keywords,
 101 );
 102
 103 my $tokenizer_re = qr/ \s* ( $tokenizer_re_str | \( | \) | \? ) \s* /xi;
 104
 105 sub _binary_op_keywords { @binary_op_keywords }
 106
 107 my %indents = (
 108    select        => 0,
 109    update        => 0,
 110    'insert into' => 0,
 111    'delete from' => 0,
 112    from          => 1,
 113    where         => 0,
 114    join          => 1,
 115    'left join'   => 1,
 116    on            => 2,
 117    'group by'    => 0,
 118    'order by'    => 0,
 119    set           => 1,
 120    into          => 1,
 121    values        => 1,
 122 );
 123
 124 my %profiles = (
 125    console => {
 126       caller_depth => 0,
 127       fill_in_placeholders => 1,
 128       indent_string => ' ',
 129       indent_amount => 2,
 130       newline       => "\n",
 131       colormap      => {},
 132       indentmap     => { %indents },
 133    },
 134    console_monochrome => {
 135       caller_depth => 0,
 136       fill_in_placeholders => 1,
 137       indent_string => ' ',
 138       indent_amount => 2,
 139       newline       => "\n",
 140       colormap      => {},
 141       indentmap     => { %indents },
 142    },
 143    html => {
 144       caller_depth => 0,
 145       fill_in_placeholders => 1,
 146       indent_string => '&nbsp;',
 147       indent_amount => 2,
 148       newline       => "<br />\n",
 149       colormap      => {
 150          select        => ['<span class="select">'  , '</span>'],
 151          'insert into' => ['<span class="insert-into">'  , '</span>'],
 152          update        => ['<span class="select">'  , '</span>'],
 153          'delete from' => ['<span class="delete-from">'  , '</span>'],
 154          where         => ['<span class="where">'   , '</span>'],
 155          from          => ['<span class="from">'    , '</span>'],
 156          join          => ['<span class="join">'    , '</span>'],
 157          on            => ['<span class="on">'      , '</span>'],
 158          'group by'    => ['<span class="group-by">', '</span>'],
 159          'order by'    => ['<span class="order-by">', '</span>'],
 160          set           => ['<span class="set">', '</span>'],
 161          into          => ['<span class="into">', '</span>'],
 162          values        => ['<span class="values">', '</span>'],
 163       },
 164       indentmap     => { %indents },
 165    },
 166    none => {
 167       colormap      => {},
 168       indentmap     => {},
 169    },
 170 );
 171
 172 eval {
 173    require Term::ANSIColor;
 174    $profiles{console}->{colormap} = {
 175       select        => [Term::ANSIColor::color('red'), Term::ANSIColor::color('reset')],
 176       'insert into' => [Term::ANSIColor::color('red'), Term::ANSIColor::color('reset')],
 177       update        => [Term::ANSIColor::color('red'), Term::ANSIColor::color('reset')],
 178       'delete from' => [Term::ANSIColor::color('red'), Term::ANSIColor::color('reset')],
 179
 180       set           => [Term::ANSIColor::color('cyan'), Term::ANSIColor::color('reset')],
 181       from          => [Term::ANSIColor::color('cyan'), Term::ANSIColor::color('reset')],
 182
 183       where         => [Term::ANSIColor::color('green'), Term::ANSIColor::color('reset')],
 184       values        => [Term::ANSIColor::color('yellow'), Term::ANSIColor::color('reset')],
 185
 186       join          => [Term::ANSIColor::color('magenta'), Term::ANSIColor::color('reset')],
 187       'left join'   => [Term::ANSIColor::color('magenta'), Term::ANSIColor::color('reset')],
 188       on            => [Term::ANSIColor::color('blue'), Term::ANSIColor::color('reset')],
 189
 190       'group by'    => [Term::ANSIColor::color('yellow'), Term::ANSIColor::color('reset')],
 191       'order by'    => [Term::ANSIColor::color('yellow'), Term::ANSIColor::color('reset')],
 192    };
 193 };
 194
 195 sub new {
 196    my $class = shift;
 197    my $args  = shift || {};
 198
 199    my $profile = delete $args->{profile} || 'none';
 200    my $data = merge( $profiles{$profile}, $args );
 201
 202    bless $data, $class
 203 }
 204
 205 sub parse {
 206   my ($self, $s) = @_;
 207
 208   # tokenize string, and remove all optional whitespace
 209   my $tokens = [];
 210   foreach my $token (split $tokenizer_re, $s) {
 211     push @$tokens, $token if (length $token) && ($token =~ /\S/);
 212   }
 213
 214   my $tree = $self->_recurse_parse($tokens, PARSE_TOP_LEVEL);
 215   return $tree;
 216 }
 217
 218 sub _recurse_parse {
 219   my ($self, $tokens, $state) = @_;
 220
 221   my $left;
 222   while (1) { # left-associative parsing
 223
 224     my $lookahead = $tokens->[0];
 225     if ( not defined($lookahead)
 226           or
 227         ($state == PARSE_IN_PARENS && $lookahead eq ')')
 228           or
 229         ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords ) )
 230           or
 231         ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords, @binary_op_keywords, 'AND', 'OR', 'NOT' ) )
 232     ) {
 233       return $left;
 234     }
 235
 236     my $token = shift @$tokens;
 237
 238     # nested expression in ()
 239     if ($token eq '(' ) {
 240       my $right = $self->_recurse_parse($tokens, PARSE_IN_PARENS);
 241       $token = shift @$tokens   or croak "missing closing ')' around block " . $self->unparse($right);
 242       $token eq ')'             or croak "unexpected token '$token' terminating block " . $self->unparse($right);
 243
 244       $left = $left ? [@$left, [PAREN => [$right] ]]
 245                     : [PAREN  => [$right] ];
 246     }
 247     # AND/OR
 248     elsif ($token =~ /^ (?: OR | AND ) $/xi )  {
 249       my $op = uc $token;
 250       my $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
 251
 252       # Merge chunks if logic matches
 253       if (ref $right and $op eq $right->[0]) {
 254         $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
 255       }
 256       else {
 257        $left = [$op => [$left, $right]];
 258       }
 259     }
 260     # binary operator keywords
 261     elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
 262       my $op = uc $token;
 263       my $right = $self->_recurse_parse($tokens, PARSE_RHS);
 264
 265       # A between with a simple LITERAL for a 1st RHS argument needs a
 266       # rerun of the search to (hopefully) find the proper AND construct
 267       if ($op eq 'BETWEEN' and $right->[0] eq 'LITERAL') {
 268         unshift @$tokens, $right->[1][0];
 269         $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
 270       }
 271
 272       $left = [$op => [$left, $right] ];
 273     }
 274     # expression terminator keywords (as they start a new expression)
 275     elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
 276       my $op = uc $token;
 277       my $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
 278       $left = $left ? [ $left,  [$op => [$right] ]]
 279                     : [ $op => [$right] ];
 280     }
 281     # NOT (last as to allow all other NOT X pieces first)
 282     elsif ( $token =~ /^ not $/ix ) {
 283       my $op = uc $token;
 284       my $right = $self->_recurse_parse ($tokens, PARSE_RHS);
 285       $left = $left ? [ @$left, [$op => [$right] ]]
 286                     : [ $op => [$right] ];
 287
 288     }
 289     # literal (eat everything on the right until RHS termination)
 290     else {
 291       my $right = $self->_recurse_parse ($tokens, PARSE_RHS);
 292       $left = $left ? [ $left, [LITERAL => [join ' ', $token, $self->unparse($right)||()] ] ]
 293                     : [ LITERAL => [join ' ', $token, $self->unparse($right)||()] ];
 294     }
 295   }
 296 }
 297
 298 sub format_keyword {
 299   my ($self, $keyword) = @_;
 300
 301   if (my $around = $self->colormap->{lc $keyword}) {
 302      $keyword = "$around->[0]$keyword$around->[1]";
 303   }
 304
 305   return $keyword
 306 }
 307
 308 my %starters = (
 309    select        => 1,
 310    update        => 1,
 311    'insert into' => 1,
 312    'delete from' => 1,
 313 );
 314
 315 sub whitespace {
 316    my ($self, $keyword, $depth) = @_;
 317
 318    my $before = '';
 319    if (defined $self->indentmap->{lc $keyword}) {
 320       $before = $self->newline . $self->indent($depth + $self->indentmap->{lc $keyword});
 321    }
 322    $before = '' if $depth == 0 and defined $starters{lc $keyword};
 323    return [$before, ' '];
 324 }
 325
 326 sub indent { ($_[0]->indent_string||'') x ( ( $_[0]->indent_amount || 0 ) * $_[1] ) }
 327
 328 sub _is_key {
 329    my ($self, $tree) = @_;
 330    $tree = $tree->[0] while ref $tree;
 331
 332    defined $tree && defined $self->indentmap->{lc $tree};
 333 }
 334
 335 sub _fill_in_placeholder {
 336    my ($self, $bindargs) = @_;
 337
 338    if ($self->fill_in_placeholders) {
 339       my $val = pop @{$bindargs} || '';
 340       $val =~ s/\\/\\\\/g;
 341       $val =~ s/'/\\'/g;
 342       return qq('$val')
 343    }
 344    return '?'
 345 }
 346
 347 sub _caller_info {
 348    my ($self, $depth) = @_;
 349
 350    return '' if $depth != 1 or !$self->include_caller;
 351
 352    my @caller_info = caller($self->caller_depth + 0);
 353
 354    " at $caller_info[1] line $caller_info[2].";
 355 }
 356
 357 sub unparse {
 358   my ($self, $tree, $bindargs, $indent, $depth) = @_;
 359
 360   $depth  ||= 0;
 361   $indent ||= 0;
 362
 363   if (not $tree ) {
 364     return '';
 365   }
 366
 367   my $car = $tree->[0];
 368   my $cdr = $tree->[1];
 369
 370   if (ref $car) {
 371     return join ('', map $self->unparse($_, $bindargs, $indent, $depth + 1), @$tree);
 372   }
 373   elsif ($car eq 'LITERAL') {
 374     if ($cdr->[0] eq '?') {
 375       return $self->_fill_in_placeholder($bindargs)
 376     }
 377     return $cdr->[0];
 378   }
 379   elsif ($car eq 'PAREN') {
 380     return '(' .
 381       join(' ',
 382         map $self->unparse($_, $bindargs, $indent + 2, $depth + 1), @{$cdr}) .
 383     ($self->_is_key($cdr)?( $self->newline||'' ).$self->indent($indent + 1):'') . ') ';
 384   }
 385   elsif ($car eq 'OR' or $car eq 'AND' or (grep { $car =~ /^ $_ $/xi } @binary_op_keywords ) ) {
 386     return join (" $car ", map $self->unparse($_, $bindargs, $indent, $depth + 1), @{$cdr});
 387   }
 388   else {
 389     my ($l, $r) = @{$self->whitespace($car, $indent)};
 390     return sprintf "$l%s %s$r%s", $self->format_keyword($car), $self->unparse($cdr, $bindargs, $indent, $depth + 1), $self->_caller_info($depth);
 391   }
 392 }
 393
 394 sub format { my $self = shift; $self->unparse($self->parse($_[0]), $_[1]) }
 395
 396 1;
 397
 398 =pod
 399
 400 =head1 SYNOPSIS
 401
 402  my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' });
 403
 404  print $sqla_tree->format('SELECT * FROM foo WHERE foo.a > 2');
 405
 406  # SELECT *
 407  #   FROM foo
 408  #   WHERE foo.a > 2
 409
 410 =head1 METHODS
 411
 412 =head2 new
 413
 414  my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' });
 415
 416 =head2 format
 417
 418  $sqlat->format('SELECT * FROM bar')
 419
 420 Returns a formatting string based on wthe string passed in