[Bast-commits] r9252 -
SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract
dhoss at dev.catalyst.perl.org
dhoss at dev.catalyst.perl.org
Tue Apr 27 23:40:32 GMT 2010
Author: dhoss
Date: 2010-04-28 00:40:32 +0100 (Wed, 28 Apr 2010)
New Revision: 9252
Modified:
SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Test.pm
SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Tree.pm
Log:
added a shitload of debug stuff, and fixed up method calling. only 416 test failing
Modified: SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Test.pm
===================================================================
--- SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Test.pm 2010-04-27 22:35:29 UTC (rev 9251)
+++ SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Test.pm 2010-04-27 23:40:32 UTC (rev 9252)
@@ -16,6 +16,10 @@
our $tb = __PACKAGE__->builder;
our $tree = SQL::Abstract::Tree->new;
+# set up attrs
+$tree->case_sensitive($case_sensitive);
+$tree->parenthesis_significant($parenthesis_significant);
+
sub is_same_sql_bind {
my ( $sql1, $bind_ref1, $sql2, $bind_ref2, $msg ) = @_;
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-04-27 22:35:29 UTC (rev 9251)
+++ SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Tree.pm 2010-04-27 23:40:32 UTC (rev 9252)
@@ -84,7 +84,7 @@
lazy_build => 1,
);
-sub _build_binary_op_keyworkds {
+sub _build_binary_op_keywords {
my $self = shift;
return (
map {
@@ -111,10 +111,10 @@
);
sub _build_tokenizer_re_str {
- my $self = shift;
- return join( "\n\t|\n",
- ( map { '\b' . $_ . '\b' } $self->expression_terminator_sql_keywords, 'AND', 'OR', 'NOT' ),
- $self->binary_op_keywords, );
+ my $self = shift;
+ my @expr = $self->expression_terminator_sql_keywords;
+ my @binops = $self->binary_op_keywords;
+ return join( "\n\t|\n", ( map { '\b' . $_ . '\b' } @expr, 'AND', 'OR', 'NOT' ), @binops );
}
has 'tokenizer_re' => (
@@ -125,7 +125,8 @@
sub _build_tokenizer_re {
my $self = shift;
- return qr/ \s* ( $self->tokenizer_re_str | \( | \) | \? ) \s* /xi;
+ my $re = $self->tokenizer_re_str;
+ return qr/ \s* ( $re | \( | \) | \? ) \s* /xi;
}
has 'unrollable_ops' => (
@@ -149,11 +150,13 @@
# tokenize string, and remove all optional whitespace
my $tokens = [];
- foreach my $token ( split $self->tokenizer_re, $s ) {
+ my $re = $self->tokenizer_re;
+ warn "Tokenizer re:" . Dumper $re;
+ foreach my $token ( split $re, $s ) {
push @$tokens, $token if ( length $token ) && ( $token =~ /\S/ );
}
-
- my $tree = _recurse_parse( $tokens, PARSE_TOP_LEVEL );
+ warn "Tokens from parse: " . Dumper $tokens;
+ my $tree = $self->_recurse_parse( $tokens, PARSE_TOP_LEVEL );
return $tree;
}
@@ -161,33 +164,37 @@
my ( $self, $tokens, $state ) = @_;
my $left;
+ my @expr = $self->expression_terminator_sql_keywords;
+ my @binops = $self->binary_op_keywords;
while (1) { # left-associative parsing
-
+ warn "Tokens: " . Dumper $tokens;
my $lookahead = $tokens->[0];
+ warn "Lookahead: $lookahead";
if (
- not defined($lookahead)
+ not defined($lookahead)
or ( $state == PARSE_IN_PARENS && $lookahead eq ')' )
or ( $state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi }
- ( '\)', $self->expression_terminator_sql_keywords ) )
+ ( '\)', @expr ) )
or (
$state == PARSE_RHS
&& grep { $lookahead =~ /^ $_ $/xi } (
- '\)', $self->expression_terminator_sql_keywords,
- $self->binary_op_keywords, 'AND', 'OR', 'NOT'
+ '\)', @expr,
+ @binops, 'AND', 'OR', 'NOT'
)
)
)
{
+ warn "Got to return left";
return $left;
}
-
+ warn "shifting tokens: " . Dumper @$tokens;
my $token = shift @$tokens;
# 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] ] ]
@@ -197,7 +204,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] ) {
@@ -210,13 +217,13 @@
# binary operator keywords
elsif ( grep { $token =~ /^ $_ $/xi } $self->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 ] ];
@@ -225,7 +232,7 @@
# expression terminator keywords (as they start a new expression)
elsif ( grep { $token =~ /^ $_ $/xi } $self->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] ] ]
@@ -235,7 +242,7 @@
# 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] ] ]
@@ -245,11 +252,11 @@
# literal (eat everything on the right until RHS termination)
else {
- my $right = _recurse_parse( $tokens, PARSE_RHS );
+ my $right = $self->_recurse_parse( $tokens, PARSE_RHS );
$left =
$left
- ? [ $left, [ LITERAL => [ join ' ', $token, unparse($right) || () ] ] ]
- : [ LITERAL => [ join ' ', $token, unparse($right) || () ] ];
+ ? [ $left, [ LITERAL => [ join ' ', $token, $self->unparse($right) || () ] ] ]
+ : [ LITERAL => [ join ' ', $token, $self->unparse($right) || () ] ];
}
}
}
@@ -321,26 +328,26 @@
sub unparse {
my ( $self, $tree ) = shift;
-
+ my @binops = $self->binary_op_keywords;
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
- } $self->binary_op_keywords
+ } @binops
)
)
{
- 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', $tree->[0], $self->unparse( $tree->[1] );
}
}
More information about the Bast-commits
mailing list