[Bast-commits] r9666 - in SQL-Abstract/1.x/branches/sqla-tree:
lib/SQL/Abstract t
frew at dev.catalyst.perl.org
frew at dev.catalyst.perl.org
Wed Sep 1 04:13:03 GMT 2010
Author: frew
Date: 2010-09-01 05:13:03 +0100 (Wed, 01 Sep 2010)
New Revision: 9666
Modified:
SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Tree.pm
SQL-Abstract/1.x/branches/sqla-tree/t/11unparse.t
Log:
OO-ify and add some silly colors for fun
Modified: SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Tree.pm
===================================================================
--- SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Tree.pm 2010-09-01 03:55:49 UTC (rev 9665)
+++ SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Tree.pm 2010-09-01 04:13:03 UTC (rev 9666)
@@ -70,8 +70,10 @@
sub _binary_op_keywords { @binary_op_keywords }
+sub new { bless sub {}, shift }
+
sub parse {
- my $s = shift;
+ my ($self, $s) = @_;
# tokenize string, and remove all optional whitespace
my $tokens = [];
@@ -79,12 +81,12 @@
push @$tokens, $token if (length $token) && ($token =~ /\S/);
}
- my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
+ my $tree = $self->_recurse_parse($tokens, PARSE_TOP_LEVEL);
return $tree;
}
sub _recurse_parse {
- my ($tokens, $state) = @_;
+ my ($self, $tokens, $state) = @_;
my $left;
while (1) { # left-associative parsing
@@ -105,9 +107,9 @@
# nested expression in ()
if ($token eq '(' ) {
- my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
- $token = shift @$tokens or croak "missing closing ')' around block " . unparse ($right);
- $token eq ')' or croak "unexpected token '$token' terminating block " . unparse ($right);
+ my $right = $self->_recurse_parse($tokens, PARSE_IN_PARENS);
+ $token = shift @$tokens or croak "missing closing ')' around block " . $self->unparse($right);
+ $token eq ')' or croak "unexpected token '$token' terminating block " . $self->unparse($right);
$left = $left ? [@$left, [PAREN => [$right] ]]
: [PAREN => [$right] ];
@@ -115,7 +117,7 @@
# AND/OR
elsif ($token =~ /^ (?: OR | AND ) $/xi ) {
my $op = uc $token;
- my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
+ my $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
# Merge chunks if logic matches
if (ref $right and $op eq $right->[0]) {
@@ -128,13 +130,13 @@
# binary operator keywords
elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
my $op = uc $token;
- my $right = _recurse_parse($tokens, PARSE_RHS);
+ my $right = $self->_recurse_parse($tokens, PARSE_RHS);
# A between with a simple LITERAL for a 1st RHS argument needs a
# rerun of the search to (hopefully) find the proper AND construct
if ($op eq 'BETWEEN' and $right->[0] eq 'LITERAL') {
unshift @$tokens, $right->[1][0];
- $right = _recurse_parse($tokens, PARSE_IN_EXPR);
+ $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
}
$left = [$op => [$left, $right] ];
@@ -142,51 +144,69 @@
# expression terminator keywords (as they start a new expression)
elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
my $op = uc $token;
- my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
+ my $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
$left = $left ? [ $left, [$op => [$right] ]]
: [ $op => [$right] ];
}
# NOT (last as to allow all other NOT X pieces first)
elsif ( $token =~ /^ not $/ix ) {
my $op = uc $token;
- my $right = _recurse_parse ($tokens, PARSE_RHS);
+ my $right = $self->_recurse_parse ($tokens, PARSE_RHS);
$left = $left ? [ @$left, [$op => [$right] ]]
: [ $op => [$right] ];
}
# literal (eat everything on the right until RHS termination)
else {
- my $right = _recurse_parse ($tokens, PARSE_RHS);
- $left = $left ? [ $left, [LITERAL => [join ' ', $token, unparse($right)||()] ] ]
- : [ LITERAL => [join ' ', $token, unparse($right)||()] ];
+ my $right = $self->_recurse_parse ($tokens, PARSE_RHS);
+ $left = $left ? [ $left, [LITERAL => [join ' ', $token, $self->unparse($right)||()] ] ]
+ : [ LITERAL => [join ' ', $token, $self->unparse($right)||()] ];
}
}
}
+use Term::ANSIColor 'color';
+
+my %ghetto_colormap = (
+ select => [color('red'), color('reset')],
+ where => [color('green'), color('reset')],
+ from => [color('cyan'), color('reset')],
+);
+
+sub format_keyword {
+ my ($self, $keyword) = @_;
+
+ if (my $around = $ghetto_colormap{lc $keyword}) {
+ $keyword = "$around->[0]$keyword$around->[1]";
+ }
+
+ return $keyword
+}
+
sub unparse {
- my $tree = shift;
+ my ($self, $tree) = @_;
if (not $tree ) {
return '';
}
elsif (ref $tree->[0]) {
- return join (" ", map { unparse ($_) } @$tree);
+ return join (" ", map $self->unparse ($_), @$tree);
}
elsif ($tree->[0] eq 'LITERAL') {
return $tree->[1][0];
}
elsif ($tree->[0] eq 'PAREN') {
- return sprintf '(%s)', join (" ", map {unparse($_)} @{$tree->[1]});
+ return sprintf '(%s)', join (" ", map $self->unparse($_), @{$tree->[1]});
}
elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @binary_op_keywords ) ) {
- return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]});
+ return join (" $tree->[0] ", map $self->unparse($_), @{$tree->[1]});
}
else {
- return sprintf '%s %s', $tree->[0], unparse ($tree->[1]);
+ return sprintf '%s %s', $self->format_keyword($tree->[0]), $self->unparse ($tree->[1]);
}
}
-sub format { unparse(parse(@_)) }
+sub format { my $self = shift; $self->unparse($self->parse(@_)) }
1;
Modified: SQL-Abstract/1.x/branches/sqla-tree/t/11unparse.t
===================================================================
--- SQL-Abstract/1.x/branches/sqla-tree/t/11unparse.t 2010-09-01 03:55:49 UTC (rev 9665)
+++ SQL-Abstract/1.x/branches/sqla-tree/t/11unparse.t 2010-09-01 04:13:03 UTC (rev 9666)
@@ -3,20 +3,20 @@
use SQL::Abstract::Tree;
+my $sqlat = SQL::Abstract::Tree->new;
+
{
- my $sql = "SELECT a, b, c
- FROM foo WHERE foo.a =1 and foo.b LIKE 'station'";
+ my $sql = "SELECT a, b, c FROM foo WHERE foo.a =1 and foo.b LIKE 'station'";
print "$sql\n";
- print SQL::Abstract::Tree::format($sql) . "\n";
+ print $sqlat->format($sql) . "\n";
}
{
- my $sql = "SELECT *
- FROM (SELECT * FROM foobar) WHERE foo.a =1 and foo.b LIKE 'station'";
+ my $sql = "SELECT * FROM (SELECT * FROM foobar) WHERE foo.a =1 and foo.b LIKE 'station'";
print "$sql\n";
- print SQL::Abstract::Tree::format($sql) . "\n";
+ print $sqlat->format($sql) . "\n";
}
# stuff we want:
More information about the Bast-commits
mailing list