[Bast-commits] r8533 - in SQL-Abstract/1.x/branches/test_refactor:
. lib/SQL/Abstract t
ribasushi at dev.catalyst.perl.org
ribasushi at dev.catalyst.perl.org
Thu Feb 4 13:23:19 GMT 2010
Author: ribasushi
Date: 2010-02-04 13:23:16 +0000 (Thu, 04 Feb 2010)
New Revision: 8533
Modified:
SQL-Abstract/1.x/branches/test_refactor/Changes
SQL-Abstract/1.x/branches/test_refactor/lib/SQL/Abstract/Test.pm
SQL-Abstract/1.x/branches/test_refactor/t/05in_between.t
SQL-Abstract/1.x/branches/test_refactor/t/07subqueries.t
Log:
Things look saner now
Modified: SQL-Abstract/1.x/branches/test_refactor/Changes
===================================================================
--- SQL-Abstract/1.x/branches/test_refactor/Changes 2010-02-04 13:00:05 UTC (rev 8532)
+++ SQL-Abstract/1.x/branches/test_refactor/Changes 2010-02-04 13:23:16 UTC (rev 8533)
@@ -1,5 +1,7 @@
Revision history for SQL::Abstract
+ - Another iteration of SQL::Abstract::Test fixes and improvements
+
revision 1.60 2009-09-22 11:03 (UTC)
----------------------------
- fix a well masked error in the sql-test tokenizer
Modified: SQL-Abstract/1.x/branches/test_refactor/lib/SQL/Abstract/Test.pm
===================================================================
--- SQL-Abstract/1.x/branches/test_refactor/lib/SQL/Abstract/Test.pm 2010-02-04 13:00:05 UTC (rev 8532)
+++ SQL-Abstract/1.x/branches/test_refactor/lib/SQL/Abstract/Test.pm 2010-02-04 13:23:16 UTC (rev 8533)
@@ -40,6 +40,7 @@
)',
'ON',
'WHERE',
+ 'EXISTS',
'GROUP \s+ BY',
'HAVING',
'ORDER \s+ BY',
@@ -58,11 +59,14 @@
# * 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 $stuff_around_mathops = qr/[\w\s\`\'\"\)]/;
my @binary_op_keywords = (
( map
- { " (?<= $stuff_around_mathops) " . quotemeta $_ . "(?= $stuff_around_mathops )" }
- (qw/< > != = <= >=/)
+ {
+ ' ^ ' . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
+ " (?<= $stuff_around_mathops)" . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ",
+ }
+ (qw/< > != <> = <= >=/)
),
( map
{ '\b (?: NOT \s+)?' . $_ . '\b' }
@@ -75,7 +79,7 @@
@binary_op_keywords,
);
-my $tokenizer_re = qr/ \s* ( \( | \) | \? | $tokenizer_re_str ) \s* /xi;
+my $tokenizer_re = qr/ \s* ( $tokenizer_re_str | \( | \) | \? ) \s* /xi;
# All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
my @unrollable_ops = (
@@ -216,7 +220,7 @@
_parenthesis_unroll ($_) for ($left, $right);
# if operators are different
- if ($left->[0] ne $right->[0]) {
+ if ( $left->[0] ne $right->[0] ) {
$sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
unparse($left),
unparse($right);
@@ -224,7 +228,7 @@
}
# elsif operators are identical, compare operands
else {
- if ($left->[0] eq 'EXPR' ) { # unary operator
+ 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);
@@ -246,10 +250,7 @@
# tokenize string, and remove all optional whitespace
my $tokens = [];
foreach my $token (split $tokenizer_re, $s) {
- $token =~ s/\s+/ /g;
- $token =~ s/\s+([^\w\s])/$1/g;
- $token =~ s/([^\w\s])\s+/$1/g;
- push @$tokens, $token if length $token;
+ push @$tokens, $token if (length $token) && ($token =~ /\S/);
}
my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
@@ -277,7 +278,7 @@
my $token = shift @$tokens;
# nested expression in ()
- if ($token eq '(') {
+ 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);
@@ -302,9 +303,9 @@
my $op = uc $token;
my $right = _recurse_parse($tokens, PARSE_RHS);
- # A between with a simple EXPR for a 1st RHS argument needs a
+ # 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 'EXPR') {
+ if ($op eq 'BETWEEN' and $right->[0] eq 'LITERAL') {
unshift @$tokens, $right->[1][0];
$right = _recurse_parse($tokens, PARSE_IN_EXPR);
}
@@ -326,10 +327,11 @@
: [[ $op => [$right] ]];
}
- # leaf expression
+ # literal (eat everything on the right until RHS termination)
else {
- $left = $left ? [@$left, [EXPR => [$token] ] ]
- : [ EXPR => [$token] ];
+ my $right = _recurse_parse ($tokens, PARSE_RHS);
+ $left = $left ? [$left, [LITERAL => [join ' ', $token, unparse($right)||()] ] ]
+ : [ LITERAL => [join ' ', $token, unparse($right)||()] ];
}
}
}
@@ -373,23 +375,23 @@
$changes++;
}
- # only one EXPR element in the parenthesis
+ # only one LITERAL element in the parenthesis
elsif (
- @{$child->[1]} == 1 && $child->[1][0][0] eq 'EXPR'
+ @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
) {
push @children, $child->[1][0];
$changes++;
}
- # only one element in the parenthesis which is a binary op with two EXPR sub-children
+ # 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 } (@binary_op_keywords)
and
- $child->[1][0][1][0][0] eq 'EXPR'
+ $child->[1][0][1][0][0] eq 'LITERAL'
and
- $child->[1][0][1][1][0] eq 'EXPR'
+ $child->[1][0][1][1][0] eq 'LITERAL'
) {
push @children, $child->[1][0];
$changes++;
@@ -416,7 +418,7 @@
elsif (ref $tree->[0]) {
return join (" ", map { unparse ($_) } @$tree);
}
- elsif ($tree->[0] eq 'EXPR') {
+ elsif ($tree->[0] eq 'LITERAL') {
return $tree->[1][0];
}
elsif ($tree->[0] eq 'PAREN') {
Modified: SQL-Abstract/1.x/branches/test_refactor/t/05in_between.t
===================================================================
--- SQL-Abstract/1.x/branches/test_refactor/t/05in_between.t 2010-02-04 13:00:05 UTC (rev 8532)
+++ SQL-Abstract/1.x/branches/test_refactor/t/05in_between.t 2010-02-04 13:23:16 UTC (rev 8533)
@@ -101,14 +101,14 @@
{
parenthesis_significant => 1,
where => { x => { -in => \'( 1,2,lower(y) )' } },
- stmt => "WHERE ( x IN (1, 2, lower(y) ) )",
+ stmt => "WHERE ( x IN ( 1,2,lower(y) ) )",
bind => [],
test => '-in with a literal scalarref',
},
{
parenthesis_significant => 1,
where => { x => { -in => \['( ( ?,?,lower(y) ) )', 1, 2] } },
- stmt => "WHERE ( x IN (?, ?, lower(y) ) )",
+ stmt => "WHERE ( x IN ( ?,?,lower(y) ) )", # note that outer parens are opened even though literal was requested (RIBASUSHI)
bind => [1, 2],
test => '-in with a literal arrayrefref',
},
Modified: SQL-Abstract/1.x/branches/test_refactor/t/07subqueries.t
===================================================================
--- SQL-Abstract/1.x/branches/test_refactor/t/07subqueries.t 2010-02-04 13:00:05 UTC (rev 8532)
+++ SQL-Abstract/1.x/branches/test_refactor/t/07subqueries.t 2010-02-04 13:23:16 UTC (rev 8533)
@@ -35,7 +35,7 @@
};
push @tests, {
where => $where,
- stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE ( c2 < ? AND c3 LIKE ? )) AND foo = ? )",
+ stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE (( c2 < ? AND c3 LIKE ? )) ) AND foo = ? )",
bind => [100, "foo%", 1234],
};
More information about the Bast-commits
mailing list