r54420 - in /branches/upstream/libsql-abstract-perl/current: ./ inc/Module/ inc/Module/Install/ lib/SQL/ lib/SQL/Abstract/ t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Wed Mar 17 17:31:33 UTC 2010
Author: jawnsy-guest
Date: Wed Mar 17 17:31:04 2010
New Revision: 54420
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=54420
Log:
[svn-upgrade] Integrating new upstream version, libsql-abstract-perl (1.62)
Removed:
branches/upstream/libsql-abstract-perl/current/INSTALL
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/Makefile.PL
branches/upstream/libsql-abstract-perl/current/inc/Module/Install.pm
branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Base.pm
branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Can.pm
branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Fetch.pm
branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Makefile.pm
branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Metadata.pm
branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Win32.pm
branches/upstream/libsql-abstract-perl/current/inc/Module/Install/WriteAll.pm
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/01generate.t
branches/upstream/libsql-abstract-perl/current/t/02where.t
branches/upstream/libsql-abstract-perl/current/t/04modifiers.t
branches/upstream/libsql-abstract-perl/current/t/05in_between.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=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/Changes (original)
+++ branches/upstream/libsql-abstract-perl/current/Changes Wed Mar 17 17:31:04 2010
@@ -1,4 +1,11 @@
Revision history for SQL::Abstract
+
+revision 1.62 2010-03-15 11:06 (UTC)
+----------------------------
+ - Fixed open outer parens for a multi-line literal
+ - Allow recursively-nested column-functions in WHERE
+ - Bumped minimum perl to 5.6.2 and changed tests to
+ rely on core dependencies
revision 1.61 2010-02-05 16:28 (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=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/MANIFEST (original)
+++ branches/upstream/libsql-abstract-perl/current/MANIFEST Wed Mar 17 17:31:04 2010
@@ -7,7 +7,6 @@
inc/Module/Install/Metadata.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
-INSTALL
lib/SQL/Abstract.pm
lib/SQL/Abstract/Test.pm
Makefile.PL
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=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/META.yml (original)
+++ branches/upstream/libsql-abstract-perl/current/META.yml Wed Mar 17 17:31:04 2010
@@ -3,18 +3,16 @@
author:
- 'Nathan Wiger <nate at wiger.org>'
build_requires:
- Clone: 0.31
ExtUtils::MakeMaker: 6.42
- Test::Builder: 0
- Test::Deep: 0
+ Storable: 0
Test::Exception: 0
Test::More: 0
Test::Warn: 0
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.92'
-license: gpl
+generated_by: 'Module::Install version 0.94'
+license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
@@ -26,7 +24,7 @@
requires:
List::Util: 0
Scalar::Util: 0
- perl: 5.6.1
+ perl: 5.6.2
resources:
- license: http://opensource.org/licenses/gpl-license.php
-version: 1.61
+ license: http://dev.perl.org/licenses/
+version: 1.62
Modified: branches/upstream/libsql-abstract-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/Makefile.PL?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/Makefile.PL (original)
+++ branches/upstream/libsql-abstract-perl/current/Makefile.PL Wed Mar 17 17:31:04 2010
@@ -2,23 +2,21 @@
use strict;
use warnings;
-use 5.006001;
+use 5.006002;
-perl_version '5.006001';
+perl_version '5.006002';
name 'SQL-Abstract';
author 'Nathan Wiger <nate at wiger.org>';
all_from 'lib/SQL/Abstract.pm';
-requires "List::Util" => 0;
-requires "Scalar::Util" => 0;
+requires 'List::Util' => 0;
+requires 'Scalar::Util' => 0;
-test_requires "Test::Builder" => 0;
-test_requires "Test::Deep" => 0;
test_requires "Test::More" => 0;
test_requires "Test::Exception" => 0;
test_requires "Test::Warn" => 0;
-test_requires "Clone" => 0.31;
+test_requires "Storable" => 0; # for cloning in tests
tests_recursive 't';
Modified: branches/upstream/libsql-abstract-perl/current/inc/Module/Install.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/inc/Module/Install.pm?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/inc/Module/Install.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/inc/Module/Install.pm Wed Mar 17 17:31:04 2010
@@ -28,7 +28,7 @@
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.92';
+ $VERSION = '0.94';
# Storage for the pseudo-singleton
$MAIN = undef;
Modified: branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Base.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Base.pm?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Base.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Base.pm Wed Mar 17 17:31:04 2010
@@ -4,7 +4,7 @@
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.92';
+ $VERSION = '0.94';
}
# Suspend handler for "redefined" warnings
Modified: branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Can.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Can.pm?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Can.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Can.pm Wed Mar 17 17:31:04 2010
@@ -9,7 +9,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.92';
+ $VERSION = '0.94';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
Modified: branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Fetch.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Fetch.pm?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Fetch.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Fetch.pm Wed Mar 17 17:31:04 2010
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.92';
+ $VERSION = '0.94';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
Modified: branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Makefile.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Makefile.pm?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Makefile.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Makefile.pm Wed Mar 17 17:31:04 2010
@@ -7,7 +7,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.92';
+ $VERSION = '0.94';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -118,6 +118,9 @@
%test_dir = ();
require File::Find;
File::Find::find( \&_wanted_t, $dir );
+ if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
+ File::Find::find( \&_wanted_t, 'xt' );
+ }
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
@@ -157,15 +160,23 @@
$args->{NAME} = $self->module_name || $self->name;
$args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
+ $DB::single = 1;
if ( $self->tests ) {
- $args->{test} = { TESTS => $self->tests };
+ $args->{test} = {
+ TESTS => $self->tests,
+ };
+ } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
+ $args->{test} = {
+ TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
+ };
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
if ( $self->makemaker(6.10) ) {
- $args->{NO_META} = 1;
+ $args->{NO_META} = 1;
+ #$args->{NO_MYMETA} = 1;
}
if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
@@ -224,10 +235,12 @@
$args->{INSTALLDIRS} = $self->installdirs;
- my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+ my %args = map {
+ ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
+ } keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
- if (my $preop = $self->admin->preop($user_preop)) {
+ if ( my $preop = $self->admin->preop($user_preop) ) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
@@ -297,4 +310,4 @@
__END__
-#line 426
+#line 439
Modified: branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Metadata.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Metadata.pm?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Metadata.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Metadata.pm Wed Mar 17 17:31:04 2010
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.92';
+ $VERSION = '0.94';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -230,7 +230,7 @@
die("The path '$file' does not exist, or is not a file");
}
- $self->{values}{all_from} = $file;
+ $self->{values}{all_from} = $file;
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
@@ -451,6 +451,7 @@
my @phrases = (
'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1,
'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'Artistic and GPL' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
Modified: branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Win32.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Win32.pm?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Win32.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/inc/Module/Install/Win32.pm Wed Mar 17 17:31:04 2010
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.92';
+ $VERSION = '0.94';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
Modified: branches/upstream/libsql-abstract-perl/current/inc/Module/Install/WriteAll.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/inc/Module/Install/WriteAll.pm?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/inc/Module/Install/WriteAll.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/inc/Module/Install/WriteAll.pm Wed Mar 17 17:31:04 2010
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.92';;
+ $VERSION = '0.94';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
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=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract.pm Wed Mar 17 17:31:04 2010
@@ -8,14 +8,14 @@
use Carp;
use strict;
use warnings;
-use List::Util qw/first/;
-use Scalar::Util qw/blessed/;
+use List::Util ();
+use Scalar::Util ();
#======================================================================
# GLOBALS
#======================================================================
-our $VERSION = '1.61';
+our $VERSION = '1.62';
# This would confuse some packagers
#$VERSION = eval $VERSION; # numify for warning-free dev releases
@@ -82,10 +82,18 @@
# default comparison is "=", but can be overridden
$opt{cmp} ||= '=';
+ # generic SQL comparison operators
+ my $anchored_cmp_ops = join ('|', map { '^' . $_ . '$' } (
+ '(?:is \s+)? (?:not \s+)? like',
+ 'is',
+ (map { quotemeta($_) } (qw/ < > != <> = <= >= /) ),
+ ));
+ $opt{cmp_ops} = qr/$anchored_cmp_ops/ix;
+
# try to recognize which are the 'equality' and 'unequality' ops
# (temporary quickfix, should go through a more seasoned API)
- $opt{equality_op} = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i;
- $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i;
+ $opt{equality_op} = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i;
+ $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i;
# SQL booleans
$opt{sqltrue} ||= '1=1';
@@ -118,16 +126,22 @@
my ($sql, @bind) = $self->$method($data);
$sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
- if (my $fields = $options->{returning}) {
- my $f = $self->_SWITCH_refkind($fields, {
- ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$fields;},
- SCALAR => sub {$self->_quote($fields)},
- SCALARREF => sub {$$fields},
- });
- $sql .= join " ", $self->_sqlcase(' returning'), $f;
+ if (my $ret = $options->{returning}) {
+ $sql .= $self->_insert_returning ($ret);
}
return wantarray ? ($sql, @bind) : $sql;
+}
+
+sub _insert_returning {
+ my ($self, $fields) = @_;
+
+ my $f = $self->_SWITCH_refkind($fields, {
+ ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$fields;},
+ SCALAR => sub {$self->_quote($fields)},
+ SCALARREF => sub {$$fields},
+ });
+ return join (' ', $self->_sqlcase(' returning'), $f);
}
sub _insert_HASHREF { # explicit list of fields and then values
@@ -446,15 +460,46 @@
my ($self, $where) = @_;
my (@sql_clauses, @all_bind);
- for my $k (sort keys %$where) {
+ for my $k (sort keys %$where) {
my $v = $where->{$k};
- # ($k => $v) is either a special op or a regular hashpair
- my ($sql, @bind) = ($k =~ /^(-.+)/) ? $self->_where_op_in_hash($1, $v)
- : do {
- my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
- $self->$method($k, $v);
- };
+ # ($k => $v) is either a special unary op or a regular hashpair
+ my ($sql, @bind) = do {
+ if ($k =~ /^-./) {
+ # put the operator in canonical form
+ my $op = $k;
+ $op =~ s/^-//; # remove initial dash
+ $op =~ s/[_\t ]+/ /g; # underscores and whitespace become single spaces
+ $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
+
+ $self->_debug("Unary OP(-$op) within hashref, recursing...");
+
+ my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}};
+ if (my $handler = $op_entry->{handler}) {
+ if (not ref $handler) {
+ if ($op =~ s/\s?\d+$//) {
+ belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
+ . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
+ }
+ $self->$handler ($op, $v);
+ }
+ elsif (ref $handler eq 'CODE') {
+ $handler->($self, $op, $v);
+ }
+ else {
+ puke "Illegal handler for operator $k - expecting a method name or a coderef";
+ }
+ }
+ else {
+ $self->debug("Generic unary OP: $k - recursing as function");
+ $self->_where_func_generic ($op, $v);
+ }
+ }
+ else {
+ my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
+ $self->$method($k, $v);
+ }
+ };
push @sql_clauses, $sql;
push @all_bind, @bind;
@@ -463,40 +508,34 @@
return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind);
}
-
-sub _where_op_in_hash {
- my ($self, $orig_op, $v) = @_;
-
- # put the operator in canonical form
- my $op = $orig_op;
- $op =~ s/^-//; # remove initial dash
- $op =~ s/[_\t ]+/ /g; # underscores and whitespace become single spaces
- $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
-
- $self->_debug("OP(-$op) within hashref, recursing...");
-
- my $op_entry = first {$op =~ $_->{regex}} @{$self->{unary_ops}};
- my $handler = $op_entry->{handler};
- if (! $handler) {
- puke "unknown operator: $orig_op";
- }
- elsif (not ref $handler) {
- if ($op =~ s/\s?\d+$//) {
- belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
- . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
- }
- return $self->$handler ($op, $v);
- }
- elsif (ref $handler eq 'CODE') {
- return $handler->($self, $op, $v);
- }
- else {
- puke "Illegal handler for operator $orig_op - expecting a method name or a coderef";
- }
+sub _where_func_generic {
+ my ($self, $op, $rhs) = @_;
+
+ my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, {
+ SCALAR => sub {
+ puke "Illegal use of top-level '$op'"
+ unless $self->{_nested_func_lhs};
+
+ return (
+ $self->_convert('?'),
+ $self->_bindtype($self->{_nested_func_lhs}, $rhs)
+ );
+ },
+ FALLBACK => sub {
+ $self->_recurse_where ($rhs)
+ },
+ });
+
+ $sql = sprintf ('%s%s',
+ $self->_sqlcase($op),
+ ($op =~ $self->{cmp_ops}) ? " $sql" : "( $sql )",
+ );
+
+ return ($sql, @bind);
}
sub _where_op_ANDOR {
- my ($self, $op, $v) = @_;
+ my ($self, $op, $v) = @_;
$self->_SWITCH_refkind($v, {
ARRAYREF => sub {
@@ -532,22 +571,6 @@
$self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- return $self->_where_ARRAYREF($v, '');
- },
-
- HASHREF => sub {
- return $self->_where_HASHREF($v);
- },
-
- SCALARREF => sub { # literal SQL
- return ($$v);
- },
-
- ARRAYREFREF => sub { # literal SQL
- return @{${$v}};
- },
-
SCALAR => sub { # permissively interpreted as SQL
belch "literal SQL should be -nest => \\'scalar' "
. "instead of -nest => 'scalar' ";
@@ -557,6 +580,11 @@
UNDEF => sub {
puke "-$op => undef not supported";
},
+
+ FALLBACK => sub {
+ $self->_recurse_where ($v);
+ },
+
});
}
@@ -567,34 +595,27 @@
my ( $prefix, $suffix ) = ( $op =~ /\bnot\b/i )
? ( '(NOT ', ')' )
: ( '', '' );
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- my ( $sql, @bind ) = $self->_where_ARRAYREF($v, '');
- return ( ($prefix . $sql . $suffix), @bind );
- },
-
- ARRAYREFREF => sub {
- my ( $sql, @bind ) = @{ ${$v} };
- return ( ($prefix . $sql . $suffix), @bind );
- },
-
- HASHREF => sub {
- my ( $sql, @bind ) = $self->_where_HASHREF($v);
- return ( ($prefix . $sql . $suffix), @bind );
- },
-
- SCALARREF => sub { # literal SQL
- return ($prefix . $$v . $suffix);
- },
-
- SCALAR => sub { # interpreted as SQL column
- return ($prefix . $self->_convert($self->_quote($v)) . $suffix);
- },
-
- UNDEF => sub {
- puke "-$op => undef not supported";
- },
- });
+
+ my ($sql, @bind) = do {
+ $self->_SWITCH_refkind($v, {
+ SCALAR => sub { # interpreted as SQL column
+ $self->_convert($self->_quote($v));
+ },
+
+ UNDEF => sub {
+ puke "-$op => undef not supported";
+ },
+
+ FALLBACK => sub {
+ $self->_recurse_where ($v);
+ },
+ });
+ };
+
+ return (
+ join ('', $prefix, $sql, $suffix),
+ @bind,
+ );
}
@@ -633,6 +654,8 @@
my ($self, $k, $v, $logic) = @_;
$logic ||= 'and';
+ local $self->{_nested_func_lhs} = $self->{_nested_func_lhs};
+
my ($all_sql, @all_bind);
for my $orig_op (sort keys %$v) {
@@ -646,9 +669,12 @@
my ($sql, @bind);
+ # CASE: col-value logic modifiers
+ if ( $orig_op =~ /^ \- (and|or) $/xi ) {
+ ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $1);
+ }
# CASE: special operators like -in or -between
- my $special_op = first {$op =~ $_->{regex}} @{$self->{special_ops}};
- if ($special_op) {
+ elsif ( my $special_op = List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}} ) {
my $handler = $special_op->{handler};
if (! $handler) {
puke "No handler supplied for special operator $orig_op";
@@ -670,12 +696,6 @@
($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val);
},
- SCALARREF => sub { # CASE: col => {op => \$scalar} (literal SQL without bind)
- $sql = join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($op),
- $$val;
- },
-
ARRAYREFREF => sub { # CASE: col => {op => \[$sql, @bind]} (literal SQL with bind)
my ($sub_sql, @sub_bind) = @$$val;
$self->_assert_bindval_matches_bindtype(@sub_bind);
@@ -685,10 +705,6 @@
@bind = @sub_bind;
},
- HASHREF => sub {
- ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $op);
- },
-
UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
my $is = ($op =~ $self->{equality_op}) ? 'is' :
($op =~ $self->{inequality_op}) ? 'is not' :
@@ -696,11 +712,18 @@
$sql = $self->_quote($k) . $self->_sqlcase(" $is null");
},
- FALLBACK => sub { # CASE: col => {op => $scalar}
- $sql = join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($op),
- $self->_convert('?');
- @bind = $self->_bindtype($k, $val);
+ FALLBACK => sub { # CASE: col => {op/func => $stuff}
+
+ # if we are starting to nest and the first func is not a cmp op
+ # assume equality
+ my $prefix;
+ unless ($self->{_nested_func_lhs}) {
+ $self->{_nested_func_lhs} = $k;
+ $prefix = $self->{cmp} unless $op =~ $self->{cmp_ops};
+ }
+
+ ($sql, @bind) = $self->_where_func_generic ($op, $val);
+ $sql = join ' ', $self->_convert($self->_quote($k)), $prefix||(), $sql;
},
});
}
@@ -928,7 +951,7 @@
# adding them back in the corresponding method
sub _open_outer_paren {
my ($self, $sql) = @_;
- $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/x;
+ $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/xs;
return $sql;
}
@@ -1150,7 +1173,7 @@
while (1) {
# blessed objects are treated like scalars
- $ref = (blessed $data) ? '' : ref $data;
+ $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
$n_steps += 1 if $ref;
last if $ref ne 'REF';
$data = $$data;
@@ -1173,19 +1196,29 @@
sub _METHOD_FOR_refkind {
my ($self, $meth_prefix, $data) = @_;
- my $method = first {$_} map {$self->can($meth_prefix."_".$_)}
- $self->_try_refkind($data)
- or puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
- return $method;
+
+ my $method;
+ for ($self->_try_refkind($data)) {
+ $method = $self->can($meth_prefix."_".$_)
+ and last;
+ }
+
+ return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
}
sub _SWITCH_refkind {
my ($self, $data, $dispatch_table) = @_;
- my $coderef = first {$_} map {$dispatch_table->{$_}}
- $self->_try_refkind($data)
- or puke "no dispatch entry for ".$self->_refkind($data);
+ my $coderef;
+ for ($self->_try_refkind($data)) {
+ $coderef = $dispatch_table->{$_}
+ and last;
+ }
+
+ puke "no dispatch entry for ".$self->_refkind($data)
+ unless $coderef;
+
$coderef->();
}
@@ -2685,9 +2718,9 @@
=head1 LICENSE
-This module is free software; you may copy this under the terms of
-the GNU General Public License, or the Artistic License, copies of
-which should have accompanied your Perl kit.
+This module is free software; you may copy this under the same
+terms as perl itself (either the GNU General Public License or
+the Artistic License)
=cut
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=54420&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 Wed Mar 17 17:31:04 2010
@@ -6,7 +6,6 @@
use Data::Dumper;
use Carp;
use Test::Builder;
-use Test::Deep qw(eq_deeply);
our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
&eq_sql_bind &eq_sql &eq_bind
@@ -177,7 +176,10 @@
sub eq_bind {
my ($bind_ref1, $bind_ref2) = @_;
- return eq_deeply($bind_ref1, $bind_ref2);
+ local $Data::Dumper::Useqq = 1;
+ local $Data::Dumper::Sortkeys = 1;
+
+ return Dumper($bind_ref1) eq Dumper($bind_ref2);
}
sub eq_sql {
Modified: branches/upstream/libsql-abstract-perl/current/t/01generate.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/t/01generate.t?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/01generate.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/01generate.t Wed Mar 17 17:31:04 2010
@@ -231,10 +231,10 @@
#26
{
func => 'select',
- args => ['test', '*', {priority => [ -and => {'!=', 2}, {'!=', 1} ]}],
- stmt => 'SELECT * FROM test WHERE ( ( ( priority != ? ) AND ( priority != ? ) ) )',
- stmt_q => 'SELECT * FROM `test` WHERE ( ( ( `priority` != ? ) AND ( `priority` != ? ) ) )',
- bind => [qw(2 1)],
+ args => ['test', '*', {priority => [ -and => {'!=', 2}, { -not_like => '3%'} ]}],
+ stmt => 'SELECT * FROM test WHERE ( ( ( priority != ? ) AND ( priority NOT LIKE ? ) ) )',
+ stmt_q => 'SELECT * FROM `test` WHERE ( ( ( `priority` != ? ) AND ( `priority` NOT LIKE ? ) ) )',
+ bind => [qw(2 3%)],
},
#27
{
@@ -583,6 +583,14 @@
stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id',
stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING id',
bind => [qw/1 2 3 4 5/],
+ },
+ {
+ func => 'select',
+ new => {bindtype => 'columns'},
+ args => ['test', '*', [ Y => { -max => { -LENGTH => { -min => 'x' } } } ] ],
+ stmt => 'SELECT * FROM test WHERE ( Y = MAX( LENGTH( MIN( ? ) ) ) )',
+ stmt_q => 'SELECT * FROM `test` WHERE ( `Y` = MAX( LENGTH( MIN( ? ) ) ) )',
+ bind => [[Y => 'x']],
},
);
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=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/02where.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/02where.t Wed Mar 17 17:31:04 2010
@@ -309,6 +309,30 @@
bind => [1, 2],
},
+# Op against internal function
+ {
+ where => { bool1 => { '=' => { -not_bool => 'bool2' } } },
+ stmt => " WHERE ( bool1 = (NOT bool2) )",
+ bind => [],
+ },
+ {
+ where => { -not_bool => { -not_bool => { -not_bool => 'bool2' } } },
+ stmt => " WHERE ( NOT ( NOT ( NOT bool2 ) ) )",
+ bind => [],
+ },
+
+# Op against random functions (these two are oracle-specific)
+ {
+ where => { timestamp => { '!=' => { -trunc => \'sysdate' } } },
+ stmt => " WHERE ( timestamp != TRUNC(sysdate) )",
+ bind => [],
+ },
+ {
+ where => { timestamp => { '>=' => { -TO_DATE => '2009-12-21 00:00:00' } } },
+ stmt => " WHERE ( timestamp >= TO DATE(?) )",
+ bind => ['2009-12-21 00:00:00'],
+ },
+
);
plan tests => ( @handle_tests * 2 ) + 1;
Modified: branches/upstream/libsql-abstract-perl/current/t/04modifiers.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/t/04modifiers.t?rev=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/04modifiers.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/04modifiers.t Wed Mar 17 17:31:04 2010
@@ -7,8 +7,8 @@
use SQL::Abstract::Test import => ['is_same_sql_bind'];
use Data::Dumper;
+use Storable qw/dclone/;
use SQL::Abstract;
-use Clone;
=begin
Test -and -or and -nest modifiers, assuming the following:
@@ -384,7 +384,7 @@
local $SIG{__WARN__} = sub { push @w, @_ };
my $sql = SQL::Abstract->new ($case->{args} || {});
- my $where_copy = Clone::clone ($case->{where});
+ my $where_copy = dclone($case->{where});
lives_ok (sub {
my ($stmt, @bind) = $sql->where($case->{where});
Modified: 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=54420&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/05in_between.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/05in_between.t Wed Mar 17 17:31:04 2010
@@ -115,6 +115,16 @@
{
parenthesis_significant => 1,
where => {
+ status => { -in => \"(SELECT status_codes\nFROM states)" },
+ },
+ # failed to open outer parens on a multi-line query in 1.61 (semifor)
+ stmt => " WHERE ( status IN ( SELECT status_codes FROM states )) ",
+ bind => [],
+ test => '-in multi-line subquery test',
+ },
+ {
+ parenthesis_significant => 1,
+ where => {
customer => { -in => \[
'SELECT cust_id FROM cust WHERE balance > ?',
2000,
More information about the Pkg-perl-cvs-commits
mailing list