[Bast-commits] r9655 - 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 Aug 25 04:18:25 GMT 2010
Author: frew
Date: 2010-08-25 05:18:25 +0100 (Wed, 25 Aug 2010)
New Revision: 9655
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
SQL-Abstract/1.x/branches/sqla-tree/t/10test.t
Log:
replace most lexicals in place of object accessors
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-08-25 03:26:02 UTC (rev 9654)
+++ SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Test.pm 2010-08-25 04:18:25 UTC (rev 9655)
@@ -7,36 +7,19 @@
use Carp;
use Test::Builder;
-our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
- &eq_sql_bind &eq_sql &eq_bind
- $case_sensitive $sql_differ/;
+__PACKAGE__->mk_group_accessors(inherited => 'case_sensitive');
+__PACKAGE__->mk_group_accessors(inherited => 'parenthesis_significant');
+__PACKAGE__->mk_group_accessors(inherited => 'sql_differ');
+__PACKAGE__->mk_group_accessors(inherited => '_tb');
-our $case_sensitive = 0;
-our $parenthesis_significant = 0;
-our $sql_differ; # keeps track of differing portion between SQLs
-our $tb = __PACKAGE__->builder;
+sub tb {
+ my $self = shift;
-# These are binary operator keywords always a single LHS and RHS
-# * AND/OR are handled separately as they are N-ary
-# * so is NOT as being unary
-# * BETWEEN without paranthesis around the ANDed arguments (which
-# makes it a non-binary op) is detected and accomodated in
-# _recurse_parse()
-my $stuff_around_mathops = qr/[\w\s\`\'\"\)]/;
-my @binary_op_keywords = (
- ( map
- {
- ' ^ ' . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
- " (?<= $stuff_around_mathops)" . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
- }
- (qw/< > != <> = <= >=/)
- ),
- ( map
- { '\b (?: NOT \s+)?' . $_ . '\b' }
- (qw/IN BETWEEN LIKE/)
- ),
-);
+ $self->_tb(__PACKAGE__->builder) unless $self->_tb;
+ return $self->_tb;
+}
+
# All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
my @unrollable_ops = (
'ON',
@@ -54,7 +37,7 @@
my $same_bind = $self->eq_bind($bind_ref1, $bind_ref2);
# call Test::Builder::ok
- my $ret = $tb->ok($same_sql && $same_bind, $msg);
+ my $ret = $self->tb->ok($same_sql && $same_bind, $msg);
# add debugging info
if (!$same_sql) {
@@ -75,7 +58,7 @@
my $same_sql = $self->eq_sql($sql1, $sql2);
# call Test::Builder::ok
- my $ret = $tb->ok($same_sql, $msg);
+ my $ret = $self->tb->ok($same_sql, $msg);
# add debugging info
if (!$same_sql) {
@@ -93,7 +76,7 @@
my $same_bind = $self->eq_bind($bind_ref1, $bind_ref2);
# call Test::Builder::ok
- my $ret = $tb->ok($same_bind, $msg);
+ my $ret = $self->tb->ok($same_bind, $msg);
# add debugging info
if (!$same_bind) {
@@ -107,17 +90,17 @@
sub _sql_differ_diag {
my ($self, $sql1, $sql2) = @_;
- $tb->diag("SQL expressions differ\n"
+ $self->tb->diag("SQL expressions differ\n"
." got: $sql1\n"
."expected: $sql2\n"
- ."differing in :\n$sql_differ\n"
+ ."differing in :\n" . $self->sql_differ. "\n"
);
}
sub _bind_differ_diag {
my ($self, $bind_ref1, $bind_ref2) = @_;
- $tb->diag("BIND values differ\n"
+ $self->tb->diag("BIND values differ\n"
." got: " . Dumper($bind_ref1)
."expected: " . Dumper($bind_ref2)
);
@@ -162,7 +145,7 @@
}
# one is a list, the other is an op with a list
elsif (ref $left->[0] xor ref $right->[0]) {
- $sql_differ = sprintf ("left: %s\nright: %s\n", map { $self->unparse ($_) } ($left, $right) );
+ $self->sql_differ(sprintf ("left: %s\nright: %s\n", map { $self->unparse ($_) } ($left, $right) ));
return 0;
}
# one is a list, so is the other
@@ -180,9 +163,11 @@
# if operators are different
if ( $left->[0] ne $right->[0] ) {
- $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
- $self->unparse($left),
- $self->unparse($right);
+ $self->sql_differ(
+ sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
+ $self->unparse($left),
+ $self->unparse($right)
+ );
return 0;
}
# elsif operators are identical, compare operands
@@ -190,13 +175,13 @@
if ($left->[0] eq 'LITERAL' ) { # unary
(my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
(my $r = " $right->[1][0] ") =~ s/\s+/ /g;
- my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
- $sql_differ = "[$l] != [$r]\n" if not $eq;
+ my $eq = $self->case_sensitive ? $l eq $r : uc($l) eq uc($r);
+ $self->sql_differ("[$l] != [$r]\n") if not $eq;
return $eq;
}
else {
my $eq = $self->_eq_sql($left->[1], $right->[1]);
- $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $self->unparse ($_) } ($left, $right) ) if not $eq;
+ $self->sql_differ($self->sql_differ || sprintf ("left: %s\nright: %s\n", map { $self->unparse ($_) } ($left, $right) )) if not $eq;
return $eq;
}
}
@@ -206,7 +191,7 @@
sub _parenthesis_unroll {
my ($self, $ast) = @_;
- return if $parenthesis_significant;
+ return if $self->parenthesis_significant;
return unless (ref $ast and ref $ast->[1]);
my $changes;
@@ -254,7 +239,7 @@
elsif (
@{$child->[1]} == 1
and
- grep { $child->[1][0][0] =~ /^ $_ $/xi } (@binary_op_keywords)
+ grep { $child->[1][0][0] =~ /^ $_ $/xi } (@{$self->binary_op_keywords})
and
$child->[1][0][1][0][0] eq 'LITERAL'
and
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-08-25 03:26:02 UTC (rev 9654)
+++ SQL-Abstract/1.x/branches/sqla-tree/lib/SQL/Abstract/Tree.pm 2010-08-25 04:18:25 UTC (rev 9655)
@@ -10,70 +10,93 @@
use constant PARSE_IN_PARENS => 2;
use constant PARSE_RHS => 3;
+use base 'Class::Accessor::Grouped';
+
+__PACKAGE__->mk_group_accessors(inherited => '_expression_terminator_sql_keywords');
+__PACKAGE__->mk_group_accessors(inherited => '_binary_op_keywords');
+__PACKAGE__->mk_group_accessors(inherited => '_tokenizer_re');
+
# These SQL keywords always signal end of the current expression (except inside
# of a parenthesized subexpression).
# Format: A list of strings that will be compiled to extended syntax (ie.
# /.../x) regexes, without capturing parentheses. They will be automatically
# anchored to word boundaries to match the whole token).
-my @expression_terminator_sql_keywords = (
- 'SELECT',
- 'FROM',
- '(?:
- (?:
- (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
- (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
- )?
- JOIN
- )',
- 'ON',
- 'WHERE',
- 'EXISTS',
- 'GROUP \s+ BY',
- 'HAVING',
- 'ORDER \s+ BY',
- 'LIMIT',
- 'OFFSET',
- 'FOR',
- 'UNION',
- 'INTERSECT',
- 'EXCEPT',
- 'RETURNING',
-);
+sub expression_terminator_sql_keywords {
+ my $self = shift;
+ unless ($self->_expression_terminator_sql_keywords) {
+ $self->_expression_terminator_sql_keywords([
+ 'SELECT',
+ 'FROM',
+ '(?:
+ (?:
+ (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
+ (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
+ )?
+ JOIN
+ )',
+ 'ON',
+ 'WHERE',
+ 'EXISTS',
+ 'GROUP \s+ BY',
+ 'HAVING',
+ 'ORDER \s+ BY',
+ 'LIMIT',
+ 'OFFSET',
+ 'FOR',
+ 'UNION',
+ 'INTERSECT',
+ 'EXCEPT',
+ 'RETURNING',
+ ]);
+ }
+
+ return $self->_expression_terminator_sql_keywords;
+}
+
# These are binary operator keywords always a single LHS and RHS
# * AND/OR are handled separately as they are N-ary
# * so is NOT as being unary
# * BETWEEN without paranthesis around the ANDed arguments (which
# makes it a non-binary op) is detected and accomodated in
# _recurse_parse()
-my @binary_op_keywords;
+sub binary_op_keywords {
+ my $self = shift;
-{
- my $stuff_around_mathops = qr/[\w\s\`\'\"\)]/;
- @binary_op_keywords = (
- ( map
- {
- ' ^ ' . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
- " (?<= $stuff_around_mathops)" . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
- }
- (qw/< > != <> = <= >=/)
- ),
- ( map
- { '\b (?: NOT \s+)?' . $_ . '\b' }
- (qw/IN BETWEEN LIKE/)
- ),
- );
+ unless ($self->_binary_op_keywords) {
+ my $stuff_around_mathops = qr/[\w\s\`\'\"\)]/;
+
+ $self->_binary_op_keywords([
+ ( map
+ {
+ ' ^ ' . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
+ " (?<= $stuff_around_mathops)" . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
+ }
+ (qw/< > != <> = <= >=/)
+ ),
+ ( map
+ { '\b (?: NOT \s+)?' . $_ . '\b' }
+ (qw/IN BETWEEN LIKE/)
+ ),
+ ]);
+ }
+
+ return $self->_binary_op_keywords;
}
-my $tokenizer_re;
+sub tokenizer_re {
+ my $self = shift;
-{
- my $tokenizer_re_str = join("\n\t|\n",
- ( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR', 'NOT'),
- @binary_op_keywords,
- );
+ unless ($self->_tokenizer_re) {
+ my $tokenizer_re_str = join("\n\t|\n",
+ ( map { '\b' . $_ . '\b' } @{__PACKAGE__->expression_terminator_sql_keywords}, 'AND', 'OR', 'NOT'),
+ @{__PACKAGE__->binary_op_keywords},
+ );
- $tokenizer_re = qr/ \s* ( $tokenizer_re_str | \( | \) | \? ) \s* /xi;
+ $self->_tokenizer_re(qr/ \s* ( $tokenizer_re_str | \( | \) | \? ) \s* /xi);
+ }
+
+ return $self->_tokenizer_re;
}
sub new { bless {}, shift }
@@ -83,7 +106,7 @@
# tokenize string, and remove all optional whitespace
my $tokens = [];
- foreach my $token (split $tokenizer_re, $s) {
+ foreach my $token (split $self->tokenizer_re, $s) {
push @$tokens, $token if (length $token) && ($token =~ /\S/);
}
@@ -102,9 +125,9 @@
or
($state == PARSE_IN_PARENS && $lookahead eq ')')
or
- ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords ) )
+ ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @{$self->expression_terminator_sql_keywords} ) )
or
- ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords, @binary_op_keywords, 'AND', 'OR', 'NOT' ) )
+ ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @{$self->expression_terminator_sql_keywords}, @{$self->binary_op_keywords}, 'AND', 'OR', 'NOT' ) )
) {
return $left;
}
@@ -134,7 +157,7 @@
}
}
# binary operator keywords
- elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
+ elsif (grep { $token =~ /^ $_ $/xi } @{$self->binary_op_keywords} ) {
my $op = uc $token;
my $right = $self->_recurse_parse($tokens, PARSE_RHS);
@@ -148,7 +171,7 @@
$left = [$op => [$left, $right] ];
}
# expression terminator keywords (as they start a new expression)
- elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
+ elsif (grep { $token =~ /^ $_ $/xi } @{$self->expression_terminator_sql_keywords} ) {
my $op = uc $token;
my $right = $self->_recurse_parse($tokens, PARSE_IN_EXPR);
$left = $left ? [ $left, [$op => [$right] ]]
@@ -186,7 +209,7 @@
elsif ($tree->[0] eq 'PAREN') {
return sprintf '(%s)', join (" ", map {unparse($_)} @{$tree->[1]});
}
- elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @binary_op_keywords ) ) {
+ elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @{$self->binary_op_keywords} ) ) {
return join (" $tree->[0] ", map {$self->unparse($_)} @{$tree->[1]});
}
else {
Modified: SQL-Abstract/1.x/branches/sqla-tree/t/10test.t
===================================================================
--- SQL-Abstract/1.x/branches/sqla-tree/t/10test.t 2010-08-25 03:26:02 UTC (rev 9654)
+++ SQL-Abstract/1.x/branches/sqla-tree/t/10test.t 2010-08-25 04:18:25 UTC (rev 9655)
@@ -842,8 +842,7 @@
foreach my $sql2 (@$statements) {
no warnings qw/once/; # perl 5.10 is dumb
- local $SQL::Abstract::Test::parenthesis_significant = $test->{parenthesis_significant}
- if $test->{parenthesis_significant};
+ $sqlat->parenthesis_significant($test->{parenthesis_significant});
my $equal = $sqlat->eq_sql($sql1, $sql2);
TODO: {
More information about the Bast-commits
mailing list