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