r52194 - 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
Fri Feb 5 18:26:56 UTC 2010
Author: jawnsy-guest
Date: Fri Feb 5 18:26:41 2010
New Revision: 52194
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=52194
Log:
[svn-upgrade] Integrating new upstream version, libsql-abstract-perl (1.61)
Modified:
branches/upstream/libsql-abstract-perl/current/Changes
branches/upstream/libsql-abstract-perl/current/META.yml
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/05in_between.t
branches/upstream/libsql-abstract-perl/current/t/07subqueries.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=52194&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/Changes (original)
+++ branches/upstream/libsql-abstract-perl/current/Changes Fri Feb 5 18:26:41 2010
@@ -1,4 +1,10 @@
Revision history for SQL::Abstract
+
+revision 1.61 2010-02-05 16:28 (UTC)
+----------------------------
+ - Allow INSERT to take additional attributes
+ - Support for INSERT ... RETURNING
+ - Another iteration of SQL::Abstract::Test fixes and improvements
revision 1.60 2009-09-22 11:03 (UTC)
----------------------------
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=52194&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/META.yml (original)
+++ branches/upstream/libsql-abstract-perl/current/META.yml Fri Feb 5 18:26:41 2010
@@ -13,7 +13,7 @@
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.91'
+generated_by: 'Module::Install version 0.92'
license: gpl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -29,4 +29,4 @@
perl: 5.6.1
resources:
license: http://opensource.org/licenses/gpl-license.php
-version: 1.60
+version: 1.61
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=52194&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/inc/Module/Install.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/inc/Module/Install.pm Fri Feb 5 18:26:41 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.91';
+ $VERSION = '0.92';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -348,17 +348,24 @@
return $call;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
- if ( $] >= 5.006 ) {
- open( FH, '<', $_[0] ) or die "open($_[0]): $!";
- } else {
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
- }
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
+END_NEW
+sub _read {
+ local *FH;
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
@@ -379,18 +386,26 @@
return $string;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
- if ( $] >= 5.006 ) {
- open( FH, '>', $_[0] ) or die "open($_[0]): $!";
- } else {
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
- }
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
@@ -427,4 +442,4 @@
1;
-# Copyright 2008 - 2009 Adam Kennedy.
+# Copyright 2008 - 2010 Adam Kennedy.
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=52194&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 Fri Feb 5 18:26:41 2010
@@ -4,7 +4,7 @@
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
}
# 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=52194&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 Fri Feb 5 18:26:41 2010
@@ -9,7 +9,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@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=52194&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 Fri Feb 5 18:26:41 2010
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@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=52194&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 Fri Feb 5 18:26:41 2010
@@ -7,7 +7,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -34,6 +34,17 @@
}
}
+# Store a cleaned up version of the MakeMaker version,
+# since we need to behave differently in a variety of
+# ways based on the MM version.
+my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
+
+# If we are passed a param, do a "newer than" comparison.
+# Otherwise, just return the MakeMaker version.
+sub makemaker {
+ ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
+}
+
sub makemaker_args {
my $self = shift;
my $args = ( $self->{makemaker_args} ||= {} );
@@ -44,7 +55,7 @@
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
- my $self = sShift;
+ my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{name} = defined $args->{$name}
@@ -130,12 +141,13 @@
# an underscore, even though its own version may contain one!
# Hence the funny regexp to get rid of it. See RT #35800
# for details.
- $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+ my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
+ $self->build_requires( 'ExtUtils::MakeMaker' => $v );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
}
@@ -152,42 +164,62 @@
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ if ( $self->makemaker(6.10) ) {
$args->{NO_META} = 1;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
- # Merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
- map { @$_ }
+ map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
- ($self->configure_requires, $self->build_requires, $self->requires)
+ ($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
- # merge both kinds of requires into prereq_pm
+ # Merge both kinds of requires into BUILD_REQUIRES
+ my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
+ %$build_prereq = ( %$build_prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires)
+ );
+
+ # Remove any reference to perl, BUILD_REQUIRES doesn't support it
+ delete $args->{BUILD_REQUIRES}->{perl};
+
+ # Delete bundled dists from prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
foreach my $bundle (@{ $self->bundles }) {
my ($file, $dir) = @$bundle;
push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
+ delete $build_prereq->{$file}; #Delete from build prereqs only
}
+ }
+
+ unless ( $self->makemaker('6.55_03') ) {
+ %$prereq = (%$prereq,%$build_prereq);
+ delete $args->{BUILD_REQUIRES};
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
+
+ if ( $self->makemaker(6.48) ) {
+ $args->{MIN_PERL_VERSION} = $perl_version;
+ }
}
$args->{INSTALLDIRS} = $self->installdirs;
@@ -265,4 +297,4 @@
__END__
-#line 394
+#line 426
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=52194&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 Fri Feb 5 18:26:41 2010
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -230,6 +230,8 @@
die("The path '$file' does not exist, or is not a file");
}
+ $self->{values}{all_from} = $file;
+
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
@@ -385,11 +387,10 @@
}
}
-sub perl_version_from {
- my $self = shift;
+sub _extract_perl_version {
if (
- Module::Install::_read($_[0]) =~ m/
- ^
+ $_[0] =~ m/
+ ^\s*
(?:use|require) \s*
v?
([\d_\.]+)
@@ -398,6 +399,16 @@
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
+ return $perl_version;
+ } else {
+ return;
+ }
+}
+
+sub perl_version_from {
+ my $self = shift;
+ my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
+ if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
@@ -425,13 +436,12 @@
}
}
-sub license_from {
- my $self = shift;
+sub _extract_license {
if (
- Module::Install::_read($_[0]) =~ m/
+ $_[0] =~ m/
(
=head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
+ (?:licen[cs]e|licensing|copyrights?|legal)\b
.*?
)
(=head\\d.*|=cut.*|)
@@ -439,7 +449,8 @@
/ixms ) {
my $license_text = $1;
my @phrases = (
- 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
+ '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,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
@@ -456,20 +467,32 @@
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
+ $pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
- $self->license($license);
- return 1;
+ return $license;
}
}
- }
-
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
+ } else {
+ return;
+ }
+}
+
+sub license_from {
+ my $self = shift;
+ if (my $license=_extract_license(Module::Install::_read($_[0]))) {
+ $self->license($license);
+ } else {
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+ }
}
sub _extract_bugtracker {
- my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
+ my @links = $_[0] =~ m#L<(
+ \Qhttp://rt.cpan.org/\E[^>]+|
+ \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
+ \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
+ )>#gx;
my %links;
@links{@links}=();
@links=keys %links;
@@ -485,7 +508,7 @@
return 0;
}
if ( @links > 1 ) {
- warn "Found more than on rt.cpan.org link in $_[0]\n";
+ warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
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=52194&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 Fri Feb 5 18:26:41 2010
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@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=52194&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 Fri Feb 5 18:26:41 2010
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';;
+ $VERSION = '0.92';;
@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=52194&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract.pm (original)
+++ branches/upstream/libsql-abstract-perl/current/lib/SQL/Abstract.pm Fri Feb 5 18:26:41 2010
@@ -15,7 +15,7 @@
# GLOBALS
#======================================================================
-our $VERSION = '1.60';
+our $VERSION = '1.61';
# This would confuse some packagers
#$VERSION = eval $VERSION; # numify for warning-free dev releases
@@ -109,13 +109,24 @@
#======================================================================
sub insert {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $data = shift || return;
+ my $options = shift;
my $method = $self->_METHOD_FOR_refkind("_insert", $data);
- my ($sql, @bind) = $self->$method($data);
+ 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;
+ }
+
return wantarray ? ($sql, @bind) : $sql;
}
@@ -1675,7 +1686,7 @@
=back
-=head2 insert($table, \@values || \%fieldvals)
+=head2 insert($table, \@values || \%fieldvals, \%options)
This is the simplest function. You simply give it a table name
and either an arrayref of values or hashref of field/value pairs.
@@ -1683,6 +1694,23 @@
See the sections on L</"Inserting and Updating Arrays"> and
L</"Inserting and Updating SQL"> for information on how to insert
with those data types.
+
+The optional C<\%options> hash reference may contain additional
+options to generate the insert SQL. Currently supported options
+are:
+
+=over 4
+
+=item returning
+
+Takes either a scalar of raw SQL fields, or an array reference of
+field names, and adds on an SQL C<RETURNING> statement at the end.
+This allows you to return data generated by the insert statement
+(such as row IDs) without performing another C<SELECT> statement.
+Note, however, this is not part of the SQL standard and may not
+be supported by all database engines.
+
+=back
=head2 update($table, \%fieldvals, \%where)
@@ -2636,6 +2664,7 @@
Laurent Dami (internal refactoring, multiple -nest, extensible list of special operators, literal SQL)
Norbert Buchmuller (support for literal SQL in hashpair, misc. fixes & tests)
Peter Rabbitson (rewrite of SQLA::Test, misc. fixes & tests)
+ Oliver Charles (support for "RETURNING" after "INSERT")
Thanks!
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=52194&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 Fri Feb 5 18:26:41 2010
@@ -40,6 +40,7 @@
)',
'ON',
'WHERE',
+ 'EXISTS',
'GROUP \s+ BY',
'HAVING',
'ORDER \s+ BY',
@@ -49,6 +50,7 @@
'UNION',
'INTERSECT',
'EXCEPT',
+ 'RETURNING',
);
# These are binary operator keywords always a single LHS and RHS
@@ -57,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' }
@@ -74,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 = (
@@ -215,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);
@@ -223,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);
@@ -245,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);
@@ -276,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);
@@ -301,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);
}
@@ -325,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)||()] ];
}
}
}
@@ -372,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++;
@@ -415,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: 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=52194&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/01generate.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/01generate.t Fri Feb 5 18:26:41 2010
@@ -543,6 +543,46 @@
stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? ) OR ( a = ? AND b = ? )',
stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? OR `b` = ? ) OR ( `a` = ? AND `b` = ? )',
bind => [[a => 1], [b => 1], [ a => 2], [ b => 2]],
+ },
+ #60
+ {
+ func => 'insert',
+ args => ['test', [qw/1 2 3 4 5/], { returning => 'id' }],
+ stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id',
+ stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING `id`',
+ bind => [qw/1 2 3 4 5/],
+ },
+ #60
+ {
+ func => 'insert',
+ args => ['test', [qw/1 2 3 4 5/], { returning => 'id, foo, bar' }],
+ stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar',
+ stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING `id, foo, bar`',
+ bind => [qw/1 2 3 4 5/],
+ },
+ #61
+ {
+ func => 'insert',
+ args => ['test', [qw/1 2 3 4 5/], { returning => [qw(id foo bar) ] }],
+ stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar',
+ stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING `id`, `foo`, `bar`',
+ bind => [qw/1 2 3 4 5/],
+ },
+ #62
+ {
+ func => 'insert',
+ args => ['test', [qw/1 2 3 4 5/], { returning => \'id, foo, bar' }],
+ stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar',
+ stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar',
+ bind => [qw/1 2 3 4 5/],
+ },
+ #63
+ {
+ func => 'insert',
+ args => ['test', [qw/1 2 3 4 5/], { returning => \'id' }],
+ stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id',
+ stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING id',
+ bind => [qw/1 2 3 4 5/],
},
);
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=52194&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/05in_between.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/05in_between.t Fri Feb 5 18:26:41 2010
@@ -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: branches/upstream/libsql-abstract-perl/current/t/07subqueries.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsql-abstract-perl/current/t/07subqueries.t?rev=52194&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/07subqueries.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/07subqueries.t Fri Feb 5 18:26:41 2010
@@ -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],
};
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=52194&op=diff
==============================================================================
--- branches/upstream/libsql-abstract-perl/current/t/10test.t (original)
+++ branches/upstream/libsql-abstract-perl/current/t/10test.t Fri Feb 5 18:26:41 2010
@@ -19,7 +19,7 @@
my @sql_tests = (
- # WHERE condition - equal
+ # WHERE condition - equal
{
equal => 1,
statements => [
@@ -579,6 +579,38 @@
q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 8)) AS foo WHERE (a = 2)/,
q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 9)) AS foo WHERE (a = 2)/,
q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 10))) AS foo WHERE (a = 2)/,
+ ]
+ },
+ {
+ equal => 0,
+ statements => [
+ 'SELECT a,b,c FROM foo',
+ 'SELECT a,c,b FROM foo',
+ 'SELECT b,a,c FROM foo',
+ 'SELECT b,c,a FROM foo',
+ 'SELECT c,a,b FROM foo',
+ 'SELECT c,b,a FROM foo',
+ ],
+ },
+ {
+ equal => 0,
+ statements => [
+ 'SELECT * FROM foo WHERE a IN (1,2,3)',
+ 'SELECT * FROM foo WHERE a IN (1,3,2)',
+ 'SELECT * FROM foo WHERE a IN (2,1,3)',
+ 'SELECT * FROM foo WHERE a IN (2,3,1)',
+ 'SELECT * FROM foo WHERE a IN (3,1,2)',
+ 'SELECT * FROM foo WHERE a IN (3,2,1)',
+ ]
+ },
+ {
+ equal => 0,
+ statements => [
+ 'SELECT count(*) FROM foo',
+ 'SELECT count(*) AS bar FROM foo',
+ 'SELECT count(*) AS "bar" FROM foo',
+ 'SELECT count(a) FROM foo',
+ 'SELECT count(1) FROM foo',
]
},
);
More information about the Pkg-perl-cvs-commits
mailing list