r44639 - in /trunk/libsql-abstract-perl: Changes MANIFEST META.yml debian/changelog lib/SQL/Abstract.pm lib/SQL/Abstract/Test.pm t/02where.t t/05between.t t/05in_between.t t/10test.t
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Tue Sep 22 15:37:11 UTC 2009
Author: jawnsy-guest
Date: Tue Sep 22 15:36:36 2009
New Revision: 44639
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=44639
Log:
* New upstream release
+ Fix an error in the SQL-Test tokenizer
+ Allow -in/-between to accept literal SQL
Added:
trunk/libsql-abstract-perl/t/05in_between.t
- copied unchanged from r44638, branches/upstream/libsql-abstract-perl/current/t/05in_between.t
Removed:
trunk/libsql-abstract-perl/t/05between.t
Modified:
trunk/libsql-abstract-perl/Changes
trunk/libsql-abstract-perl/MANIFEST
trunk/libsql-abstract-perl/META.yml
trunk/libsql-abstract-perl/debian/changelog
trunk/libsql-abstract-perl/lib/SQL/Abstract.pm
trunk/libsql-abstract-perl/lib/SQL/Abstract/Test.pm
trunk/libsql-abstract-perl/t/02where.t
trunk/libsql-abstract-perl/t/10test.t
Modified: trunk/libsql-abstract-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/Changes?rev=44639&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/Changes (original)
+++ trunk/libsql-abstract-perl/Changes Tue Sep 22 15:36:36 2009
@@ -1,4 +1,16 @@
Revision history for SQL::Abstract
+
+revision 1.60 2009-09-22 11:03 (UTC)
+----------------------------
+ - fix a well masked error in the sql-test tokenizer
+
+revision 1.59 2009-09-22 08:39 (UTC)
+----------------------------
+ - fixed a couple of untrapped undefined warnings
+ - allow -in/-between to accept literal sql in all logical
+ variants - see POD for details
+ - unroll multiple parenthesis around IN arguments to accomodate
+ crappy databases
revision 1.58 2009-09-04 15:20 (UTC)
----------------------------
Modified: trunk/libsql-abstract-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/MANIFEST?rev=44639&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/MANIFEST (original)
+++ trunk/libsql-abstract-perl/MANIFEST Tue Sep 22 15:36:36 2009
@@ -18,7 +18,7 @@
t/02where.t
t/03values.t
t/04modifiers.t
-t/05between.t
+t/05in_between.t
t/06order_by.t
t/07subqueries.t
t/08special_ops.t
Modified: trunk/libsql-abstract-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/META.yml?rev=44639&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/META.yml (original)
+++ trunk/libsql-abstract-perl/META.yml Tue Sep 22 15:36:36 2009
@@ -29,4 +29,4 @@
perl: 5.6.1
resources:
license: http://opensource.org/licenses/gpl-license.php
-version: 1.58
+version: 1.60
Modified: trunk/libsql-abstract-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/debian/changelog?rev=44639&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/debian/changelog (original)
+++ trunk/libsql-abstract-perl/debian/changelog Tue Sep 22 15:36:36 2009
@@ -1,3 +1,11 @@
+libsql-abstract-perl (1.60-1) UNRELEASED; urgency=low
+
+ * New upstream release
+ + Fix an error in the SQL-Test tokenizer
+ + Allow -in/-between to accept literal SQL
+
+ -- Jonathan Yu <jawnsy at cpan.org> Tue, 22 Sep 2009 07:22:09 -0400
+
libsql-abstract-perl (1.58-1) unstable; urgency=low
[ Jonathan Yu ]
Modified: trunk/libsql-abstract-perl/lib/SQL/Abstract.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/lib/SQL/Abstract.pm?rev=44639&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/lib/SQL/Abstract.pm (original)
+++ trunk/libsql-abstract-perl/lib/SQL/Abstract.pm Tue Sep 22 15:36:36 2009
@@ -15,7 +15,7 @@
# GLOBALS
#======================================================================
-our $VERSION = '1.58';
+our $VERSION = '1.60';
# This would confuse some packagers
#$VERSION = eval $VERSION; # numify for warning-free dev releases
@@ -708,11 +708,14 @@
my @vals = @$vals; #always work on a copy
if(@vals) {
- $self->_debug("ARRAY($vals) means multiple elements: [ @vals ]");
+ $self->_debug(sprintf '%s means multiple elements: [ %s ]',
+ $vals,
+ join (', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ),
+ );
# see if the first element is an -and/-or op
my $logic;
- if ($vals[0] =~ /^ - ( AND|OR ) $/ix) {
+ if (defined $vals[0] && $vals[0] =~ /^ - ( AND|OR ) $/ix) {
$logic = uc $1;
shift @vals;
}
@@ -815,38 +818,51 @@
sub _where_field_BETWEEN {
my ($self, $k, $op, $vals) = @_;
- (ref $vals eq 'ARRAY' && @$vals == 2) or
- (ref $vals eq 'REF' && (@$$vals == 1 || @$$vals == 2 || @$$vals == 3))
- or puke "special op 'between' requires an arrayref of two values (or a scalarref or arrayrefref for literal SQL)";
-
- my ($clause, @bind, $label, $and, $placeholder);
+ my ($label, $and, $placeholder);
$label = $self->_convert($self->_quote($k));
$and = ' ' . $self->_sqlcase('and') . ' ';
$placeholder = $self->_convert('?');
$op = $self->_sqlcase($op);
- if (ref $vals eq 'REF') {
- ($clause, @bind) = @$$vals;
- }
- else {
- my (@all_sql, @all_bind);
-
- foreach my $val (@$vals) {
- my ($sql, @bind) = $self->_SWITCH_refkind($val, {
- SCALAR => sub {
- return ($placeholder, ($val));
- },
- SCALARREF => sub {
- return ($self->_convert($$val), ());
- },
- });
- push @all_sql, $sql;
- push @all_bind, @bind;
- }
-
- $clause = (join $and, @all_sql);
- @bind = $self->_bindtype($k, @all_bind);
- }
+ my ($clause, @bind) = $self->_SWITCH_refkind($vals, {
+ ARRAYREFREF => sub {
+ return @$$vals;
+ },
+ SCALARREF => sub {
+ return $$vals;
+ },
+ ARRAYREF => sub {
+ puke "special op 'between' accepts an arrayref with exactly two values"
+ if @$vals != 2;
+
+ my (@all_sql, @all_bind);
+ foreach my $val (@$vals) {
+ my ($sql, @bind) = $self->_SWITCH_refkind($val, {
+ SCALAR => sub {
+ return ($placeholder, ($val));
+ },
+ SCALARREF => sub {
+ return ($self->_convert($$val), ());
+ },
+ ARRAYREFREF => sub {
+ my ($sql, @bind) = @$$val;
+ return ($self->_convert($sql), @bind);
+ },
+ });
+ push @all_sql, $sql;
+ push @all_bind, @bind;
+ }
+
+ return (
+ (join $and, @all_sql),
+ $self->_bindtype($k, @all_bind),
+ );
+ },
+ FALLBACK => sub {
+ puke "special op 'between' accepts an arrayref with two values, or a single literal scalarref/arrayref-ref";
+ },
+ });
+
my $sql = "( $label $op $clause )";
return ($sql, @bind)
}
@@ -877,21 +893,33 @@
}
},
+ SCALARREF => sub { # literal SQL
+ my $sql = $self->_open_outer_paren ($$vals);
+ return ("$label $op ( $sql )");
+ },
ARRAYREFREF => sub { # literal SQL with bind
my ($sql, @bind) = @$$vals;
$self->_assert_bindval_matches_bindtype(@bind);
+ $sql = $self->_open_outer_paren ($sql);
return ("$label $op ( $sql )", @bind);
},
FALLBACK => sub {
- puke "special op 'in' requires an arrayref (or arrayref-ref)";
+ puke "special op 'in' requires an arrayref (or scalarref/arrayref-ref)";
},
});
return ($sql, @bind);
}
-
+# Some databases (SQLite) treat col IN (1, 2) different from
+# col IN ( (1, 2) ). Use this to strip all outer parens while
+# adding them back in the corresponding method
+sub _open_outer_paren {
+ my ($self, $sql) = @_;
+ $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/x;
+ return $sql;
+}
#======================================================================
@@ -1944,9 +1972,28 @@
(by default : C<1=0>). Similarly, C<< -not_in => [] >> generates
'sqltrue' (by default : C<1=1>).
-
-
-Another pair of operators is C<-between> and C<-not_between>,
+In addition to the array you can supply a chunk of literal sql or
+literal sql with bind:
+
+ my %where = {
+ customer => { -in => \[
+ 'SELECT cust_id FROM cust WHERE balance > ?',
+ 2000,
+ ],
+ status => { -in => \'SELECT status_codes FROM states' },
+ };
+
+would generate:
+
+ $stmt = "WHERE (
+ customer IN ( SELECT cust_id FROM cust WHERE balance > ? )
+ AND status IN ( SELECT status_codes FROM states )
+ )";
+ @bind = ('2000');
+
+
+
+Another pair of operators is C<-between> and C<-not_between>,
used with an arrayref of two values:
my %where = (
@@ -1960,6 +2007,30 @@
WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? )
+Just like with C<-in> all plausible combinations of literal SQL
+are possible:
+
+ my %where = {
+ start0 => { -between => [ 1, 2 ] },
+ start1 => { -between => \["? AND ?", 1, 2] },
+ start2 => { -between => \"lower(x) AND upper(y)" },
+ start3 => { -between => [
+ \"lower(x)",
+ \["upper(?)", 'stuff' ],
+ ] },
+ };
+
+Would give you:
+
+ $stmt = "WHERE (
+ ( start0 BETWEEN ? AND ? )
+ AND ( start1 BETWEEN ? AND ? )
+ AND ( start2 BETWEEN lower(x) AND upper(y) )
+ AND ( start3 BETWEEN lower(x) AND upper(?) )
+ )";
+ @bind = (1, 2, 1, 2, 'stuff');
+
+
These are the two builtin "special operators"; but the
list can be expanded : see section L</"SPECIAL OPERATORS"> below.
@@ -1979,6 +2050,21 @@
WHERE is_user AND NOT is_enabled
+If a more complex combination is required, testing more conditions,
+then you should use the and/or operators:-
+
+ my %where = (
+ -and => [
+ -bool => 'one',
+ -bool => 'two',
+ -bool => 'three',
+ -not_bool => 'four',
+ ],
+ );
+
+Would give you:
+
+ WHERE one AND two AND three AND NOT four
=head2 Nested conditions, -and/-or prefixes
@@ -2099,10 +2185,12 @@
);
-TMTOWTDI.
-
-Conditions on boolean columns can be expressed in the
-same way, passing a reference to an empty string :
+TMTOWTDI
+
+Conditions on boolean columns can be expressed in the same way, passing
+a reference to an empty string, however using liternal SQL in this way
+is deprecated - the preferred method is to use the boolean operators -
+see L</"Unary operators: bool"> :
my %where = (
priority => { '<', 2 },
Modified: trunk/libsql-abstract-perl/lib/SQL/Abstract/Test.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/lib/SQL/Abstract/Test.pm?rev=44639&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/lib/SQL/Abstract/Test.pm (original)
+++ trunk/libsql-abstract-perl/lib/SQL/Abstract/Test.pm Tue Sep 22 15:36:36 2009
@@ -57,15 +57,21 @@
# * 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 { "\Q$_\E" } (qw/< > != = <= >=/)),
- '(?: NOT \s+)? LIKE',
- '(?: NOT \s+)? BETWEEN',
+ ( map
+ { " (?<= $stuff_around_mathops) " . quotemeta $_ . "(?= $stuff_around_mathops )" }
+ (qw/< > != = <= >=/)
+ ),
+ ( map
+ { '\b (?: NOT \s+)?' . $_ . '\b' }
+ (qw/IN BETWEEN LIKE/)
+ ),
);
my $tokenizer_re_str = join("\n\t|\n",
( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR', 'NOT'),
- ( map { q! (?<= [\w\s\`\'\)] ) ! . $_ . q! (?= [\w\s\`\'\(] ) ! } @binary_op_keywords ),
+ @binary_op_keywords,
);
my $tokenizer_re = qr/ \s* ( \( | \) | \? | $tokenizer_re_str ) \s* /xi;
Modified: trunk/libsql-abstract-perl/t/02where.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/t/02where.t?rev=44639&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/t/02where.t (original)
+++ trunk/libsql-abstract-perl/t/02where.t Tue Sep 22 15:36:36 2009
@@ -117,6 +117,14 @@
{
where => {
+ requestor => { '!=', ['-and', undef, ''] },
+ },
+ stmt => " WHERE ( requestor IS NOT NULL AND requestor != ? )",
+ bind => [''],
+ },
+
+ {
+ where => {
priority => [ {'>', 3}, {'<', 1} ],
requestor => { '!=', undef },
},
Modified: trunk/libsql-abstract-perl/t/10test.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/t/10test.t?rev=44639&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/t/10test.t (original)
+++ trunk/libsql-abstract-perl/t/10test.t Tue Sep 22 15:36:36 2009
@@ -264,6 +264,15 @@
q/SELECT foo FROM bar WHERE a = 1 OR b = 1 AND c = 1/,
q/SELECT foo FROM bar WHERE (a = 1 OR b = 1) AND c = 1/,
q/SELECT foo FROM bar WHERE a = 1 OR (b = 1 AND c = 1)/,
+ ]
+ },
+ {
+ equal => 0,
+ parenthesis_significant => 1,
+ statements => [
+ q/SELECT foo FROM bar WHERE a IN (1,2,3)/,
+ q/SELECT foo FROM bar WHERE a IN (1,3,2)/,
+ q/SELECT foo FROM bar WHERE a IN ((1,2,3))/,
]
},
{
More information about the Pkg-perl-cvs-commits
mailing list