[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