These 'optimizations' are silly
[scpubgit/Q-Branch.git] / lib / SQL / Abstract / Tree.pm
CommitLineData
01dd4e4f 1package SQL::Abstract::Tree;
2
3use strict;
4use warnings;
5use Carp;
6
0769ac0e 7use Hash::Merge qw//;
8
9use base 'Class::Accessor::Grouped';
10
11__PACKAGE__->mk_group_accessors( simple => $_ ) for qw(
12 newline indent_string indent_amount colormap indentmap fill_in_placeholders
13 placeholder_surround
14);
2fed0b4b 15
bc482085 16my $merger = Hash::Merge->new;
17
18$merger->specify_behavior({
2fed0b4b 19 SCALAR => {
20 SCALAR => sub { $_[1] },
21 ARRAY => sub { [ $_[0], @{$_[1]} ] },
22 HASH => sub { $_[1] },
23 },
24 ARRAY => {
25 SCALAR => sub { $_[1] },
26 ARRAY => sub { $_[1] },
27 HASH => sub { $_[1] },
28 },
29 HASH => {
30 SCALAR => sub { $_[1] },
31 ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] },
32 HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) },
33 },
0769ac0e 34}, 'SQLA::Tree Behavior' );
1536de15 35
1536de15 36
01dd4e4f 37# Parser states for _recurse_parse()
38use constant PARSE_TOP_LEVEL => 0;
39use constant PARSE_IN_EXPR => 1;
40use constant PARSE_IN_PARENS => 2;
41use constant PARSE_RHS => 3;
0769ac0e 42use constant PARSE_IN_FUNC => 4;
43
44my $op_look_ahead = '(?: (?= [\s\)\(\;] ) | \z)';
45my $op_look_behind = '(?: (?<= [\s\)\(] ) | \A )';
46my $quote_left = qr/[\`\'\"\[]/;
47my $quote_right = qr/[\`\'\"\]]/;
01dd4e4f 48
49# These SQL keywords always signal end of the current expression (except inside
50# of a parenthesized subexpression).
0769ac0e 51# Format: A list of strings that will be compiled to extended syntax ie.
01dd4e4f 52# /.../x) regexes, without capturing parentheses. They will be automatically
0769ac0e 53# anchored to op boundaries (excluding quotes) to match the whole token.
54my @expression_start_keywords = (
01dd4e4f 55 'SELECT',
7853a177 56 'UPDATE',
57 'INSERT \s+ INTO',
58 'DELETE \s+ FROM',
3d910890 59 'FROM',
7853a177 60 'SET',
01dd4e4f 61 '(?:
62 (?:
0769ac0e 63 (?: (?: LEFT | RIGHT | FULL ) \s+ )?
64 (?: (?: CROSS | INNER | OUTER ) \s+ )?
01dd4e4f 65 )?
66 JOIN
67 )',
68 'ON',
69 'WHERE',
7853a177 70 'VALUES',
01dd4e4f 71 'EXISTS',
72 'GROUP \s+ BY',
73 'HAVING',
74 'ORDER \s+ BY',
75 'LIMIT',
76 'OFFSET',
77 'FOR',
78 'UNION',
79 'INTERSECT',
80 'EXCEPT',
81 'RETURNING',
8d0dd7dc 82 'ROW_NUMBER \s* \( \s* \) \s+ OVER',
01dd4e4f 83);
84
0769ac0e 85my $exp_start_re = join ("\n\t|\n", @expression_start_keywords );
b7b0f832 86$exp_start_re = qr/ $op_look_behind (?i: $exp_start_re ) $op_look_ahead /x;
0769ac0e 87
01dd4e4f 88# These are binary operator keywords always a single LHS and RHS
89# * AND/OR are handled separately as they are N-ary
90# * so is NOT as being unary
91# * BETWEEN without paranthesis around the ANDed arguments (which
92# makes it a non-binary op) is detected and accomodated in
93# _recurse_parse()
01dd4e4f 94
0769ac0e 95# this will be included in the $binary_op_re, the distinction is interesting during
96# testing as one is tighter than the other, plus mathops have different look
97# ahead/behind (e.g. "x"="y" )
98my @math_op_keywords = (qw/ < > != <> = <= >= /);
99my $math_re = join ("\n\t|\n", map
100 { "(?: (?<= [\\w\\s] | $quote_right ) | \\A )" . quotemeta ($_) . "(?: (?= [\\w\\s] | $quote_left ) | \\z )" }
101 @math_op_keywords
01dd4e4f 102);
b7b0f832 103$math_re = qr/$math_re/x;
0769ac0e 104
105sub _math_op_re { $math_re }
106
107
108my $binary_op_re = '(?: NOT \s+)? (?:' . join ('|', qw/IN BETWEEN R?LIKE/) . ')';
109$binary_op_re = "(?: $op_look_behind (?i: $binary_op_re ) $op_look_ahead ) \n\t|\n $math_re";
b7b0f832 110$binary_op_re = qr/$binary_op_re/x;
0769ac0e 111
112sub _binary_op_re { $binary_op_re }
113
01dd4e4f 114
0769ac0e 115my $tokenizer_re = join("\n\t|\n",
116 $exp_start_re,
117 $binary_op_re,
118 "$op_look_behind (?i: AND|OR|NOT ) $op_look_ahead",
119 (map { quotemeta $_ } qw/( ) ? */),
120);
01dd4e4f 121
0769ac0e 122#this one *is* capturing
123$tokenizer_re = qr/ \s* ( $tokenizer_re ) \s* /x;
01dd4e4f 124
7e5600e9 125my %indents = (
7853a177 126 select => 0,
127 update => 0,
128 'insert into' => 0,
129 'delete from' => 0,
3d910890 130 from => 1,
91916220 131 where => 0,
7853a177 132 join => 1,
133 'left join' => 1,
134 on => 2,
91916220 135 'group by' => 0,
136 'order by' => 0,
7853a177 137 set => 1,
138 into => 1,
91916220 139 values => 1,
7e5600e9 140);
141
75c3a063 142my %profiles = (
143 console => {
84c65032 144 fill_in_placeholders => 1,
9d11f0d4 145 placeholder_surround => ['?/', ''],
1536de15 146 indent_string => ' ',
75c3a063 147 indent_amount => 2,
1536de15 148 newline => "\n",
3be357b0 149 colormap => {},
7e5600e9 150 indentmap => { %indents },
aafbf833 151
152 eval { require Term::ANSIColor }
153 ? do {
154 my $c = \&Term::ANSIColor::color;
155 (
156 placeholder_surround => [$c->('black on_cyan'), $c->('reset')],
157 colormap => {
158 select => [$c->('red'), $c->('reset')],
159 'insert into' => [$c->('red'), $c->('reset')],
160 update => [$c->('red'), $c->('reset')],
161 'delete from' => [$c->('red'), $c->('reset')],
162
163 set => [$c->('cyan'), $c->('reset')],
164 from => [$c->('cyan'), $c->('reset')],
165
166 where => [$c->('green'), $c->('reset')],
167 values => [$c->('yellow'), $c->('reset')],
168
169 join => [$c->('magenta'), $c->('reset')],
170 'left join' => [$c->('magenta'), $c->('reset')],
171 on => [$c->('blue'), $c->('reset')],
172
173 'group by' => [$c->('yellow'), $c->('reset')],
174 'order by' => [$c->('yellow'), $c->('reset')],
175 }
176 );
177 } : (),
3be357b0 178 },
179 console_monochrome => {
84c65032 180 fill_in_placeholders => 1,
9d11f0d4 181 placeholder_surround => ['?/', ''],
3be357b0 182 indent_string => ' ',
183 indent_amount => 2,
184 newline => "\n",
185 colormap => {},
7e5600e9 186 indentmap => { %indents },
187 },
188 html => {
84c65032 189 fill_in_placeholders => 1,
9d11f0d4 190 placeholder_surround => ['<span class="placeholder">', '</span>'],
7e5600e9 191 indent_string => '&nbsp;',
192 indent_amount => 2,
193 newline => "<br />\n",
194 colormap => {
7853a177 195 select => ['<span class="select">' , '</span>'],
196 'insert into' => ['<span class="insert-into">' , '</span>'],
197 update => ['<span class="select">' , '</span>'],
198 'delete from' => ['<span class="delete-from">' , '</span>'],
199 where => ['<span class="where">' , '</span>'],
200 from => ['<span class="from">' , '</span>'],
201 join => ['<span class="join">' , '</span>'],
202 on => ['<span class="on">' , '</span>'],
203 'group by' => ['<span class="group-by">', '</span>'],
204 'order by' => ['<span class="order-by">', '</span>'],
205 set => ['<span class="set">', '</span>'],
206 into => ['<span class="into">', '</span>'],
207 values => ['<span class="values">', '</span>'],
1536de15 208 },
7e5600e9 209 indentmap => { %indents },
75c3a063 210 },
211 none => {
1536de15 212 colormap => {},
213 indentmap => {},
75c3a063 214 },
215);
216
217sub new {
2fed0b4b 218 my $class = shift;
219 my $args = shift || {};
75c3a063 220
221 my $profile = delete $args->{profile} || 'none';
bc482085 222 my $data = $merger->merge( $profiles{$profile}, $args );
75c3a063 223
224 bless $data, $class
225}
d695b0ad 226
01dd4e4f 227sub parse {
d695b0ad 228 my ($self, $s) = @_;
01dd4e4f 229
230 # tokenize string, and remove all optional whitespace
231 my $tokens = [];
232 foreach my $token (split $tokenizer_re, $s) {
233 push @$tokens, $token if (length $token) && ($token =~ /\S/);
234 }
235
d695b0ad 236 my $tree = $self->_recurse_parse($tokens, PARSE_TOP_LEVEL);
01dd4e4f 237 return $tree;
238}
239
240sub _recurse_parse {
d695b0ad 241 my ($self, $tokens, $state) = @_;
01dd4e4f 242
243 my $left;
244 while (1) { # left-associative parsing
245
246 my $lookahead = $tokens->[0];
247 if ( not defined($lookahead)
248 or
249 ($state == PARSE_IN_PARENS && $lookahead eq ')')
250 or
0769ac0e 251 ($state == PARSE_IN_EXPR && $lookahead =~ qr/ ^ (?: $exp_start_re | \) ) $ /x )
252 or
253 ($state == PARSE_RHS && $lookahead =~ qr/ ^ (?: $exp_start_re | $binary_op_re | (?i: AND | OR | NOT ) | \) ) $ /x )
01dd4e4f 254 or
0769ac0e 255 ($state == PARSE_IN_FUNC && $lookahead ne '(')
01dd4e4f 256 ) {
0769ac0e 257 return $left||();
01dd4e4f 258 }
259
260 my $token = shift @$tokens;
261
262 # nested expression in ()
263 if ($token eq '(' ) {
d695b0ad 264 my $right = $self->_recurse_parse($tokens, PARSE_IN_PARENS);
265 $token = shift @$tokens or croak "missing closing ')' around block " . $self->unparse($right);
266 $token eq ')' or croak "unexpected token '$token' terminating block " . $self->unparse($right);
01dd4e4f 267
0769ac0e 268 $left = $left ? [$left, [PAREN => [$right||()] ]]
269 : [PAREN => [$right||()] ];
01dd4e4f 270 }
271 # AND/OR
272 elsif ($token =~ /^ (?: OR | AND ) $/xi ) {
273 my $op = uc $token;
d695b0ad 274 my $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
01dd4e4f 275
276 # Merge chunks if logic matches
277 if (ref $right and $op eq $right->[0]) {
278 $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
279 }
280 else {
281 $left = [$op => [$left, $right]];
282 }
283 }
284 # binary operator keywords
a1e204f4 285 elsif ( $token =~ /^ $binary_op_re $ /x ) {
01dd4e4f 286 my $op = uc $token;
d695b0ad 287 my $right = $self->_recurse_parse($tokens, PARSE_RHS);
01dd4e4f 288
289 # A between with a simple LITERAL for a 1st RHS argument needs a
290 # rerun of the search to (hopefully) find the proper AND construct
291 if ($op eq 'BETWEEN' and $right->[0] eq 'LITERAL') {
292 unshift @$tokens, $right->[1][0];
d695b0ad 293 $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
01dd4e4f 294 }
295
296 $left = [$op => [$left, $right] ];
297 }
298 # expression terminator keywords (as they start a new expression)
0769ac0e 299 elsif ( $token =~ / ^ $exp_start_re $ /x ) {
01dd4e4f 300 my $op = uc $token;
d695b0ad 301 my $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
01dd4e4f 302 $left = $left ? [ $left, [$op => [$right] ]]
0769ac0e 303 : [ $op => [$right] ];
01dd4e4f 304 }
0769ac0e 305 # NOT
306 elsif ( $token =~ /^ NOT $/ix ) {
01dd4e4f 307 my $op = uc $token;
d695b0ad 308 my $right = $self->_recurse_parse ($tokens, PARSE_RHS);
01dd4e4f 309 $left = $left ? [ @$left, [$op => [$right] ]]
310 : [ $op => [$right] ];
311
312 }
0769ac0e 313 # generic function
314 elsif (@$tokens && $tokens->[0] eq '(') {
315 my $right = $self->_recurse_parse($tokens, PARSE_IN_FUNC);
316
317 $left = $left ? [ $left, [ $token => [$right||()] ]]
318 : [ $token => [$right||()] ];
319 }
01dd4e4f 320 # literal (eat everything on the right until RHS termination)
321 else {
d695b0ad 322 my $right = $self->_recurse_parse ($tokens, PARSE_RHS);
323 $left = $left ? [ $left, [LITERAL => [join ' ', $token, $self->unparse($right)||()] ] ]
324 : [ LITERAL => [join ' ', $token, $self->unparse($right)||()] ];
01dd4e4f 325 }
326 }
327}
328
d695b0ad 329sub format_keyword {
330 my ($self, $keyword) = @_;
331
1536de15 332 if (my $around = $self->colormap->{lc $keyword}) {
d695b0ad 333 $keyword = "$around->[0]$keyword$around->[1]";
334 }
335
336 return $keyword
337}
338
728f26a2 339my %starters = (
340 select => 1,
341 update => 1,
342 'insert into' => 1,
343 'delete from' => 1,
344);
345
f2ab166a 346sub pad_keyword {
a24cc3a0 347 my ($self, $keyword, $depth) = @_;
e171c446 348
349 my $before = '';
1536de15 350 if (defined $self->indentmap->{lc $keyword}) {
351 $before = $self->newline . $self->indent($depth + $self->indentmap->{lc $keyword});
a24cc3a0 352 }
728f26a2 353 $before = '' if $depth == 0 and defined $starters{lc $keyword};
b4e0e260 354 return [$before, ' '];
a24cc3a0 355}
356
1536de15 357sub indent { ($_[0]->indent_string||'') x ( ( $_[0]->indent_amount || 0 ) * $_[1] ) }
a24cc3a0 358
a97eb57c 359sub _is_key {
360 my ($self, $tree) = @_;
0569a14f 361 $tree = $tree->[0] while ref $tree;
362
a97eb57c 363 defined $tree && defined $self->indentmap->{lc $tree};
0569a14f 364}
365
9d11f0d4 366sub fill_in_placeholder {
fb272e73 367 my ($self, $bindargs) = @_;
368
369 if ($self->fill_in_placeholders) {
637bb22c 370 my $val = pop @{$bindargs} || '';
9d11f0d4 371 my ($left, $right) = @{$self->placeholder_surround};
fb272e73 372 $val =~ s/\\/\\\\/g;
373 $val =~ s/'/\\'/g;
9d11f0d4 374 return qq('$left$val$right')
fb272e73 375 }
376 return '?'
377}
378
01dd4e4f 379sub unparse {
1a3cc911 380 my ($self, $tree, $bindargs, $depth) = @_;
a24cc3a0 381
1a3cc911 382 $depth ||= 0;
01dd4e4f 383
0769ac0e 384 if (not $tree or not @$tree) {
01dd4e4f 385 return '';
386 }
a24cc3a0 387
0769ac0e 388 my ($car, $cdr) = @{$tree}[0,1];
389
390 if (! defined $car or (! ref $car and ! defined $cdr) ) {
391 require Data::Dumper;
392 Carp::confess( sprintf ( "Internal error - malformed branch at depth $depth:\n%s",
393 Data::Dumper::Dumper($tree)
394 ) );
395 }
a24cc3a0 396
397 if (ref $car) {
1a3cc911 398 return join ('', map $self->unparse($_, $bindargs, $depth), @$tree);
01dd4e4f 399 }
a24cc3a0 400 elsif ($car eq 'LITERAL') {
fb272e73 401 if ($cdr->[0] eq '?') {
9d11f0d4 402 return $self->fill_in_placeholder($bindargs)
fb272e73 403 }
a24cc3a0 404 return $cdr->[0];
01dd4e4f 405 }
a24cc3a0 406 elsif ($car eq 'PAREN') {
e171c446 407 return '(' .
a24cc3a0 408 join(' ',
1a3cc911 409 map $self->unparse($_, $bindargs, $depth + 2), @{$cdr}) .
410 ($self->_is_key($cdr)?( $self->newline||'' ).$self->indent($depth + 1):'') . ') ';
01dd4e4f 411 }
0769ac0e 412 elsif ($car eq 'AND' or $car eq 'OR' or $car =~ / ^ $binary_op_re $ /x ) {
1a3cc911 413 return join (" $car ", map $self->unparse($_, $bindargs, $depth), @{$cdr});
01dd4e4f 414 }
415 else {
f2ab166a 416 my ($l, $r) = @{$self->pad_keyword($car, $depth)};
1a3cc911 417 return sprintf "$l%s %s$r", $self->format_keyword($car), $self->unparse($cdr, $bindargs, $depth);
01dd4e4f 418 }
419}
420
fb272e73 421sub format { my $self = shift; $self->unparse($self->parse($_[0]), $_[1]) }
01dd4e4f 422
4231;
424
3be357b0 425=pod
426
427=head1 SYNOPSIS
428
429 my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' });
430
431 print $sqla_tree->format('SELECT * FROM foo WHERE foo.a > 2');
432
433 # SELECT *
434 # FROM foo
435 # WHERE foo.a > 2
436
6b1bf9f8 437=head1 METHODS
438
439=head2 new
440
441 my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' });
442
c22f502d 443 $args = {
444 profile => 'console', # predefined profile to use (default: 'none')
445 fill_in_placeholders => 1, # true for placeholder population
9d11f0d4 446 placeholder_surround => # The strings that will be wrapped around
447 [GREEN, RESET], # populated placeholders if the above is set
c22f502d 448 indent_string => ' ', # the string used when indenting
449 indent_amount => 2, # how many of above string to use for a single
450 # indent level
451 newline => "\n", # string for newline
452 colormap => {
453 select => [RED, RESET], # a pair of strings defining what to surround
454 # the keyword with for colorization
455 # ...
456 },
457 indentmap => {
458 select => 0, # A zero means that the keyword will start on
459 # a new line
460 from => 1, # Any other positive integer means that after
461 on => 2, # said newline it will get that many indents
462 # ...
463 },
464 }
465
466Returns a new SQL::Abstract::Tree object. All arguments are optional.
467
468=head3 profiles
469
470There are four predefined profiles, C<none>, C<console>, C<console_monochrome>,
471and C<html>. Typically a user will probably just use C<console> or
472C<console_monochrome>, but if something about a profile bothers you, merely
473use the profile and override the parts that you don't like.
474
6b1bf9f8 475=head2 format
476
c22f502d 477 $sqlat->format('SELECT * FROM bar WHERE x = ?', [1])
478
479Takes C<$sql> and C<\@bindargs>.
6b1bf9f8 480
1a3cc911 481Returns a formatting string based on the string passed in
ee4227a7 482
483=head2 parse
484
485 $sqlat->parse('SELECT * FROM bar WHERE x = ?')
486
487Returns a "tree" representing passed in SQL. Please do not depend on the
488structure of the returned tree. It may be stable at some point, but not yet.
489
490=head2 unparse
491
492 $sqlat->parse($tree_structure, \@bindargs)
493
494Transform "tree" into SQL, applying various transforms on the way.
495
496=head2 format_keyword
497
498 $sqlat->format_keyword('SELECT')
499
500Currently this just takes a keyword and puts the C<colormap> stuff around it.
501Later on it may do more and allow for coderef based transforms.
502
f2ab166a 503=head2 pad_keyword
ee4227a7 504
f2ab166a 505 my ($before, $after) = @{$sqlat->pad_keyword('SELECT')};
ee4227a7 506
507Returns whitespace to be inserted around a keyword.
9d11f0d4 508
509=head2 fill_in_placeholder
510
511 my $value = $sqlat->fill_in_placeholder(\@bindargs)
512
513Removes last arg from passed arrayref and returns it, surrounded with
514the values in placeholder_surround, and then surrounded with single quotes.
f2ab166a 515
516=head2 indent
517
518Returns as many indent strings as indent amounts times the first argument.
519
520=head1 ACCESSORS
521
522=head2 colormap
523
524See L</new>
525
526=head2 fill_in_placeholders
527
528See L</new>
529
530=head2 indent_amount
531
532See L</new>
533
534=head2 indent_string
535
536See L</new>
537
538=head2 indentmap
539
540See L</new>
541
542=head2 newline
543
544See L</new>
545
546=head2 placeholder_surround
547
548See L</new>
549