[Bast-commits] r9336 -
SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract
dhoss at dev.catalyst.perl.org
dhoss at dev.catalyst.perl.org
Sat May 8 04:54:51 GMT 2010
Author: dhoss
Date: 2010-05-08 05:54:51 +0100 (Sat, 08 May 2010)
New Revision: 9336
Modified:
SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Tree.pm
Log:
not tested, just removed random retarded moosing
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-05-07 23:39:52 UTC (rev 9335)
+++ SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Tree.pm 2010-05-08 04:54:51 UTC (rev 9336)
@@ -1,38 +1,24 @@
package SQL::Abstract::Tree;
-use Moose;
-use namespace::autoclean;
+use strict;
+use warnings;
+use base qw/Test::Builder::Module Exporter/;
use Data::Dumper;
use Carp;
-has 'case_sensitive' => (
- is => 'rw',
- required => 1,
- lazy => 1,
- default => 0
-);
+our $case_sensitive = 0;
-has 'parenthesis_significant' => (
- is => 'rw',
- required => 1,
- lazy => 1,
- default => 0
-);
+our $parenthesis_significant = 0;
-has 'tb' => (
- is => 'rw',
- lazy_build => 1,
- required => 1,
-);
+our $tb = __PACKAGE__->builder;
-has 'expression_terminator_sql_keywords' => (
- is => 'ro',
- required => 1,
- lazy_build => 1
-);
+sub new {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ return bless {}, $class;
+}
-sub _build_expression_terminator_sql_keywords {
- return (
+my @expression_terminator_sql_keywords = (
'SELECT',
'FROM',
'(?:
@@ -55,12 +41,8 @@
'INTERSECT',
'EXCEPT',
'RETURNING',
- );
-}
+);
-sub _build_tb {
- return __PACKAGE__->builder;
-}
# These are binary operator keywords always a single LHS and RHS
# * AND/OR are handled separately as they are N-ary
@@ -68,32 +50,17 @@
# * BETWEEN without paranthesis around the ANDed arguments (which
# makes it a non-binary op) is detected and accomodated in
# _recurse_parse()
-has 'stuff_around_mathops' => (
- is => 'ro',
- required => 1,
- lazy_build => 1
-);
+my $stuff_around_mathops = qr/[\w\s\`\'\"\)]/;
-sub _build_stuff_around_mathops {
- return qr/[\w\s\`\'\"\)]/;
-}
-has 'binary_op_keywords' => (
- is => 'ro',
- required => 1,
- lazy_build => 1,
-);
-
-sub _build_binary_op_keywords {
- my $self = shift;
- return (
+my $binary_op_keywords = (
map {
- ' ^ ' . quotemeta($_) . "(?= \$ | " . $self->stuff_around_mathops . " ) ",
+ ' ^ ' . quotemeta($_) . "(?= \$ | " . $stuff_around_mathops . " ) ",
" (?<= "
- . $self->stuff_around_mathops . ")"
+ . $stuff_around_mathops . ")"
. quotemeta($_)
. "(?= \$ | "
- . $self->stuff_around_mathops . ") ",
+ . $stuff_around_mathops . ") ",
} (qw/< > != <> = <= >=/)
),
(
@@ -102,43 +69,25 @@
} (qw/IN BETWEEN LIKE/)
);
-}
-has 'tokenizer_re_str' => (
- is => 'ro',
- required => 1,
- lazy_build => 1,
-);
-sub _build_tokenizer_re_str {
- my $self = shift;
- my @expr = $self->expression_terminator_sql_keywords;
- my @binops = $self->binary_op_keywords;
+
+my $tokenizer_re_str = sub {
+ my @expr = @expression_terminator_sql_keywords;
+ my @binops = $binary_op_keywords;
return join( "\n\t|\n", ( map { '\b' . $_ . '\b' } @expr, 'AND', 'OR', 'NOT' ), @binops );
-}
+};
-has 'tokenizer_re' => (
- is => 'ro',
- required => 1,
- lazy_build => 1,
-);
-sub _build_tokenizer_re {
- my $self = shift;
- my $re = $self->tokenizer_re_str;
+my $tokenizer_re = sub {
+ my $re = $tokenizer_re_str;
return qr/ \s* ( $re | \( | \) | \? ) \s* /xi;
-}
+};
-has 'unrollable_ops' => (
- is => 'ro',
- required => 1,
- lazy_build => 1,
-);
-sub _build_unrollable_ops {
- return ( 'ON', 'WHERE', 'GROUP \s+ BY', 'HAVING', 'ORDER \s+ BY', );
-}
+my $unrollable_ops =( 'ON', 'WHERE', 'GROUP \s+ BY', 'HAVING', 'ORDER \s+ BY', );
+
# Parser states for _recurse_parse()
use constant PARSE_TOP_LEVEL => 0;
use constant PARSE_IN_EXPR => 1;
@@ -150,7 +99,7 @@
# tokenize string, and remove all optional whitespace
my $tokens = [];
- my $re = $self->tokenizer_re;
+ my $re = $tokenizer_re;
warn "Tokenizer re:" . Dumper $re;
foreach my $token ( split $re, $s ) {
push @$tokens, $token if ( length $token ) && ( $token =~ /\S/ );
@@ -164,8 +113,8 @@
my ( $self, $tokens, $state ) = @_;
my $left;
- my @expr = $self->expression_terminator_sql_keywords;
- my @binops = $self->binary_op_keywords;
+ my @expr = @expression_terminator_sql_keywords;
+ my @binops = $binary_op_keywords;
while (1) { # left-associative parsing
warn "Tokens: " . Dumper $tokens;
my $lookahead = $tokens->[0];
@@ -215,7 +164,7 @@
}
# binary operator keywords
- elsif ( grep { $token =~ /^ $_ $/xi } $self->binary_op_keywords ) {
+ elsif ( grep { $token =~ /^ $_ $/xi } $binary_op_keywords ) {
my $op = uc $token;
my $right = $self->_recurse_parse( $tokens, PARSE_RHS );
@@ -230,7 +179,7 @@
}
# expression terminator keywords (as they start a new expression)
- elsif ( grep { $token =~ /^ $_ $/xi } $self->expression_terminator_sql_keywords ) {
+ elsif ( grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
my $op = uc $token;
my $right = $self->_recurse_parse( $tokens, PARSE_IN_EXPR );
$left =
@@ -264,7 +213,7 @@
sub _parenthesis_unroll {
my ( $self, $ast ) = @_;
- return if $self->parenthesis_significant;
+ return if $parenthesis_significant;
return unless ( ref $ast and ref $ast->[1] );
my $changes;
@@ -293,7 +242,7 @@
}
# if the parent operator explcitly allows it nuke the parenthesis
- elsif ( grep { $ast->[0] =~ /^ $_ $/xi } $self->unrollable_ops ) {
+ elsif ( grep { $ast->[0] =~ /^ $_ $/xi } $unrollable_ops ) {
push @children, $child->[1][0];
$changes++;
}
@@ -306,7 +255,7 @@
# only one element in the parenthesis which is a binary op with two LITERAL sub-children
elsif ( @{ $child->[1] } == 1
- and grep { $child->[1][0][0] =~ /^ $_ $/xi } ( $self->binary_op_keywords )
+ and grep { $child->[1][0][0] =~ /^ $_ $/xi } ( $binary_op_keywords )
and $child->[1][0][1][0][0] eq 'LITERAL'
and $child->[1][0][1][1][0] eq 'LITERAL' )
{
@@ -328,7 +277,7 @@
sub unparse {
my ( $self, $tree ) = shift;
- my @binops = $self->binary_op_keywords;
+ my @binops = $binary_op_keywords;
if ( not $tree ) {
return '';
} elsif ( ref $tree->[0] ) {
@@ -356,5 +305,4 @@
my $self = shift;
}
-__PACKAGE__->meta->make_immutable;
1;
More information about the Bast-commits
mailing list