r44637 - in /branches/upstream/libsql-abstract-perl/current: Changes MANIFEST META.yml 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:17:56 UTC 2009
Author: jawnsy-guest
Date: Tue Sep 22 15:17:43 2009
New Revision: 44637
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=44637
Log:
[svn-upgrade] Integrating new upstream version, libsql-abstract-perl (1.60)
Added:
branches/upstream/libsql-abstract-perl/current/t/05in_between.t
Removed:
branches/upstream/libsql-abstract-perl/current/t/05between.t
Modified:
branches/upstream/libsql-abstract-perl/current/Changes
branches/upstream/libsql-abstract-perl/current/MANIFEST
branches/upstream/libsql-abstract-perl/current/META.yml
branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract.pm
branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract/Test.pm
branches/upstream/libsql-abstract-perl/current/t/02where.t
branches/upstream/libsql-abstract-perl/current/t/10test.t
Modified: branches/upstream/libsql-abstract-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/Changes?rev=44637&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/Changes (original)
+++ branches/upstream/libsql-abstract-perl/current/Changes Tue Sep 22 15:17:43 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: branches/upstream/libsql-abstract-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/MANIFEST?rev=44637&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/MANIFEST (original)
+++ branches/upstream/libsql-abstract-perl/current/MANIFEST Tue Sep 22 15:17:43 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: branches/upstream/libsql-abstract-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/META.yml?rev=44637&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/META.yml (original)
+++ branches/upstream/libsql-abstract-perl/current/META.yml Tue Sep 22 15:17:43 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: branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract.pm?rev=44637&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract.pm Tue Sep 22 15:17:43 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: branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract/Test.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract/Test.pm?rev=44637&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract/Test.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract/Test.pm Tue Sep 22 15:17:43 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: branches/upstream/libsql-abstract-perl/current/t/02where.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/t/02where.t?rev=44637&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/02where.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/02where.t Tue Sep 22 15:17:43 2009
@@ -117,6 +117,14 @@
{
where => {
+ requestor => { '!=', ['-and', undef, ''] },
+ },
+ stmt => " WHERE ( requestor IS NOT NULL AND requestor != ? )",
+ bind => [''],
+ },
+
+ {
+ where => {
priority => [ {'>', 3}, {'<', 1} ],
requestor => { '!=', undef },
},
Added: branches/upstream/libsql-abstract-perl/current/t/05in_between.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/t/05in_between.t?rev=44637&op=file
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/05in_between.t (added)
+++ branches/upstream/libsql-abstract-perl/current/t/05in_between.t Tue Sep 22 15:17:43 2009
@@ -1,0 +1,163 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
+
+use Data::Dumper;
+use SQL::Abstract;
+
+my @in_between_tests = (
+ {
+ where => { x => { -between => [1, 2] } },
+ stmt => 'WHERE (x BETWEEN ? AND ?)',
+ bind => [qw/1 2/],
+ test => '-between with two placeholders',
+ },
+ {
+ where => { x => { -between => [\"1", 2] } },
+ stmt => 'WHERE (x BETWEEN 1 AND ?)',
+ bind => [qw/2/],
+ test => '-between with one literal sql arg and one placeholder',
+ },
+ {
+ where => { x => { -between => [1, \"2"] } },
+ stmt => 'WHERE (x BETWEEN ? AND 2)',
+ bind => [qw/1/],
+ test => '-between with one placeholder and one literal sql arg',
+ },
+ {
+ where => { x => { -between => [\'current_date - 1', \'current_date - 0'] } },
+ stmt => 'WHERE (x BETWEEN current_date - 1 AND current_date - 0)',
+ bind => [],
+ test => '-between with two literal sql arguments',
+ },
+ {
+ where => { x => { -between => [ \['current_date - ?', 1], \['current_date - ?', 0] ] } },
+ stmt => 'WHERE (x BETWEEN current_date - ? AND current_date - ?)',
+ bind => [1, 0],
+ test => '-between with two literal sql arguments with bind',
+ },
+ {
+ where => { x => { -between => \['? AND ?', 1, 2] } },
+ stmt => 'WHERE (x BETWEEN ? AND ?)',
+ bind => [1,2],
+ test => '-between with literal sql with placeholders (\["? AND ?", scalar, scalar])',
+ },
+ {
+ where => { x => { -between => \["'something' AND ?", 2] } },
+ stmt => "WHERE (x BETWEEN 'something' AND ?)",
+ bind => [2],
+ test => '-between with literal sql with one literal arg and one placeholder (\["\'something\' AND ?", scalar])',
+ },
+ {
+ where => { x => { -between => \["? AND 'something'", 1] } },
+ stmt => "WHERE (x BETWEEN ? AND 'something')",
+ bind => [1],
+ test => '-between with literal sql with one placeholder and one literal arg (\["? AND \'something\'", scalar])',
+ },
+ {
+ where => { x => { -between => \"'this' AND 'that'" } },
+ stmt => "WHERE (x BETWEEN 'this' AND 'that')",
+ bind => [],
+ test => '-between with literal sql with a literal (\"\'this\' AND \'that\'")',
+ },
+ {
+ where => {
+ start0 => { -between => [ 1, 2 ] },
+ start1 => { -between => \["? AND ?", 1, 2] },
+ start2 => { -between => \"lower(x) AND upper(y)" },
+ start3 => { -between => [
+ \"lower(x)",
+ \["upper(?)", 'stuff' ],
+ ] },
+ },
+ 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'],
+ test => '-between POD test',
+ },
+
+ {
+ parenthesis_significant => 1,
+ where => { x => { -in => [ 1 .. 3] } },
+ stmt => "WHERE ( x IN (?, ?, ?) )",
+ bind => [ 1 .. 3],
+ test => '-in with an array of scalars',
+ },
+ {
+ parenthesis_significant => 1,
+ where => { x => { -in => [] } },
+ stmt => "WHERE ( 0=1 )",
+ bind => [],
+ test => '-in with an empty array',
+ },
+ {
+ parenthesis_significant => 1,
+ 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) ) )",
+ bind => [1, 2],
+ test => '-in with a literal arrayrefref',
+ },
+ {
+ parenthesis_significant => 1,
+ where => {
+ customer => { -in => \[
+ 'SELECT cust_id FROM cust WHERE balance > ?',
+ 2000,
+ ]},
+ status => { -in => \'SELECT status_codes FROM states' },
+ },
+ stmt => "
+ WHERE ((
+ customer IN ( SELECT cust_id FROM cust WHERE balance > ? )
+ AND status IN ( SELECT status_codes FROM states )
+ ))
+ ",
+ bind => [2000],
+ test => '-in POD test',
+ },
+);
+
+plan tests => @in_between_tests*4;
+
+for my $case (@in_between_tests) {
+ TODO: {
+ local $TODO = $case->{todo} if $case->{todo};
+ local $SQL::Abstract::Test::parenthesis_significant = $case->{parenthesis_significant};
+
+ local $Data::Dumper::Terse = 1;
+
+ lives_ok (sub {
+
+ my @w;
+ local $SIG{__WARN__} = sub { push @w, @_ };
+ my $sql = SQL::Abstract->new ($case->{args} || {});
+ lives_ok (sub {
+ my ($stmt, @bind) = $sql->where($case->{where});
+ is_same_sql_bind(
+ $stmt,
+ \@bind,
+ $case->{stmt},
+ $case->{bind},
+ )
+ || diag "Search term:\n" . Dumper $case->{where};
+ });
+ is (@w, 0, $case->{test} || 'No warnings within in-between tests')
+ || diag join "\n", 'Emitted warnings:', @w;
+ }, "$case->{test} doesn't die");
+ }
+}
Modified: branches/upstream/libsql-abstract-perl/current/t/10test.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/t/10test.t?rev=44637&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/10test.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/10test.t Tue Sep 22 15:17:43 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