r34389 - in /trunk/libsql-abstract-perl: Changes MANIFEST META.yml debian/changelog lib/SQL/Abstract.pm lib/SQL/Abstract/Test.pm t/04modifiers.t t/05between.t t/06order_by.t t/07subqueries.t t/08special_ops.t t/09refkind.t t/10test.t
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Thu Apr 30 09:45:04 UTC 2009
Author: eloy
Date: Thu Apr 30 09:44:58 2009
New Revision: 34389
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=34389
Log:
new upstream version
Added:
trunk/libsql-abstract-perl/t/05between.t
- copied unchanged from r34388, branches/upstream/libsql-abstract-perl/current/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/04modifiers.t
trunk/libsql-abstract-perl/t/06order_by.t
trunk/libsql-abstract-perl/t/07subqueries.t
trunk/libsql-abstract-perl/t/08special_ops.t
trunk/libsql-abstract-perl/t/09refkind.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=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/Changes (original)
+++ trunk/libsql-abstract-perl/Changes Thu Apr 30 09:44:58 2009
@@ -1,8 +1,15 @@
Revision history for SQL::Abstract
+
+revision 1.52 2009-04-28 23:14 (UTC)
+----------------------------
+ - allow -between to handle [\"", \""] and \["", @bind]
+ - allow order_by to handle -asc|desc => [qw/colA colB/] (artifact from DBIx::Class)
+ - more tests and clearing up of some corner cases
+ - t/10test.t does not run by default (developer only, too cpu intensive)
----------------------------
revision 1.51 2009-03-28 10:00 (UTC)
- - fixed behavior of [-and => ... ] depending on the current
+ - fixed behavior of [-and => ... ] depending on the current
condition scope. This introduces backwards comp with 1.24
----------------------------
Modified: trunk/libsql-abstract-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/MANIFEST?rev=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/MANIFEST (original)
+++ trunk/libsql-abstract-perl/MANIFEST Thu Apr 30 09:44:58 2009
@@ -9,6 +9,7 @@
t/02where.t
t/03values.t
t/04modifiers.t
+t/05between.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=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/META.yml (original)
+++ trunk/libsql-abstract-perl/META.yml Thu Apr 30 09:44:58 2009
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: SQL-Abstract
-version: 1.51
+version: 1.52
abstract: Generate SQL from Perl data structures
author:
- Matt Trout <mst at shadowcat.co.uk>, but see the POD
Modified: trunk/libsql-abstract-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/debian/changelog?rev=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/debian/changelog (original)
+++ trunk/libsql-abstract-perl/debian/changelog Thu Apr 30 09:44:58 2009
@@ -1,3 +1,9 @@
+libsql-abstract-perl (1.52-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Krzysztof Krzyżaniak (eloy) <eloy at debian.org> Thu, 30 Apr 2009 11:42:51 +0200
+
libsql-abstract-perl (1.51-2) unstable; urgency=low
* Add missing build dependencies on libtest-deep-perl,
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=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/lib/SQL/Abstract.pm (original)
+++ trunk/libsql-abstract-perl/lib/SQL/Abstract.pm Thu Apr 30 09:44:58 2009
@@ -15,7 +15,7 @@
# GLOBALS
#======================================================================
-our $VERSION = '1.51';
+our $VERSION = '1.52';
# This would confuse some packagers
#$VERSION = eval $VERSION; # numify for warning-free dev releases
@@ -63,7 +63,7 @@
delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
# default logic for interpreting arrayrefs
- $opt{logic} = uc $opt{logic} || 'OR';
+ $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR';
# how to return bind vars
# LDNOTE: changed nwiger code : why this 'delete' ??
@@ -505,9 +505,10 @@
$self->_debug("ARRAY($k) means distribute over elements");
# put apart first element if it is an operator (-and, -or)
- my $op = ($v[0] =~ /^ - (?: AND|OR ) $/ix
- ? shift @v
- : ''
+ my $op = (
+ (defined $v[0] && $v[0] =~ /^ - (?: AND|OR ) $/ix)
+ ? shift @v
+ : ''
);
my @distributed = map { {$k => $_} } @v;
@@ -528,9 +529,10 @@
}
sub _where_hashpair_HASHREF {
- my ($self, $k, $v) = @_;
-
- my (@all_sql, @all_bind);
+ my ($self, $k, $v, $logic) = @_;
+ $logic ||= 'and';
+
+ my ($all_sql, @all_bind);
for my $op (sort keys %$v) {
my $val = $v->{$op};
@@ -569,6 +571,10 @@
$self->_sqlcase($op),
$sub_sql;
@bind = @sub_bind;
+ },
+
+ HASHREF => sub {
+ ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $op);
},
UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
@@ -587,11 +593,10 @@
});
}
- push @all_sql, $sql;
+ ($all_sql) = (defined $all_sql and $all_sql) ? $self->_join_sql_clauses($logic, [$all_sql, $sql], []) : $sql;
push @all_bind, @bind;
}
-
- return $self->_join_sql_clauses('and', \@all_sql, \@all_bind);
+ return ($all_sql, @all_bind);
}
@@ -601,18 +606,26 @@
if(@$vals) {
$self->_debug("ARRAY($vals) means multiple elements: [ @$vals ]");
+
+ # see if the first element is an -and/-or op
+ my $logic;
+ if ($vals->[0] =~ /^ - ( AND|OR ) $/ix) {
+ $logic = uc $1;
+ shift @$vals;
+ }
+
+ # distribute $op over each remaining member of @$vals, append logic if exists
+ return $self->_recurse_where([map { {$k => {$op, $_}} } @$vals], $logic);
# LDNOTE : had planned to change the distribution logic when
# $op =~ $self->{inequality_op}, because of Morgan laws :
# with {field => {'!=' => [22, 33]}}, it would be ridiculous to generate
# WHERE field != 22 OR field != 33 : the user probably means
# WHERE field != 22 AND field != 33.
- # To do this, replace the line below by :
+ # To do this, replace the above to roughly :
# my $logic = ($op =~ $self->{inequality_op}) ? 'AND' : 'OR';
# return $self->_recurse_where([map { {$k => {$op, $_}} } @$vals], $logic);
- # distribute $op over each member of @$vals
- return $self->_recurse_where([map { {$k => {$op, $_}} } @$vals]);
}
else {
# try to DWIM on equality operators
@@ -699,16 +712,39 @@
sub _where_field_BETWEEN {
my ($self, $k, $op, $vals) = @_;
- ref $vals eq 'ARRAY' && @$vals == 2
- or puke "special op 'between' requires an arrayref of two values";
-
- my ($label) = $self->_convert($self->_quote($k));
- my ($placeholder) = $self->_convert('?');
- my $and = $self->_sqlcase('and');
+ (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);
+ $label = $self->_convert($self->_quote($k));
+ $and = ' ' . $self->_sqlcase('and') . ' ';
+ $placeholder = $self->_convert('?');
$op = $self->_sqlcase($op);
- my $sql = "( $label $op $placeholder $and $placeholder )";
- my @bind = $self->_bindtype($k, @$vals);
+ 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 $sql = "( $label $op $clause )";
return ($sql, @bind)
}
@@ -802,7 +838,8 @@
my ($order) = ($key =~ /^-(desc|asc)/i)
or puke "invalid key in _order_by hash : $key";
- return $self->_quote($val) ." ". $self->_sqlcase($order);
+ $val = ref $val eq 'ARRAY' ? $val : [$val];
+ return join ', ', map { $self->_quote($_) . ' ' . $self->_sqlcase($order) } @$val;
}
@@ -1320,7 +1357,9 @@
=item sqltrue, sqlfalse
Expressions for inserting boolean values within SQL statements.
-By default these are C<1=1> and C<1=0>.
+By default these are C<1=1> and C<1=0>. They are used
+by the special operators C<-in> and C<-not_in> for generating
+correct SQL even when the argument is an empty array (see below).
=item logic
@@ -1639,7 +1678,7 @@
A field associated to an empty arrayref will be considered a
logical false and will generate 0=1.
-=head2 Key-value pairs
+=head2 Specific comparison operators
If you want to specify a different type of operator for your comparison,
you can use a hashref for a given column:
@@ -1765,6 +1804,12 @@
The reverse operator C<-not_in> generates SQL C<NOT IN> and is used in
the same way.
+
+If the argument to C<-in> is an empty array, 'sqlfalse' is generated
+(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>,
used with an arrayref of two values:
@@ -2050,19 +2095,29 @@
column name,) a hash of C<< { -desc => 'col' } >> or C<< { -asc => 'col' } >>,
or an array of either of the two previous forms. Examples:
- Given | Will Generate
+ Given | Will Generate
----------------------------------------------------------
- \'colA DESC' | ORDER BY colA DESC
- 'colA' | ORDER BY colA
- [qw/colA colB/] | ORDER BY colA, colB
- {-asc => 'colA'} | ORDER BY colA ASC
- {-desc => 'colB'} | ORDER BY colB DESC
- [ |
- {-asc => 'colA'}, | ORDER BY colA ASC, colB DESC
- {-desc => 'colB'} |
- ] |
- [colA => {-asc => 'colB'}] | ORDER BY colA, colB ASC
- ==========================================================
+ |
+ \'colA DESC' | ORDER BY colA DESC
+ |
+ 'colA' | ORDER BY colA
+ |
+ [qw/colA colB/] | ORDER BY colA, colB
+ |
+ {-asc => 'colA'} | ORDER BY colA ASC
+ |
+ {-desc => 'colB'} | ORDER BY colB DESC
+ |
+ ['colA', {-asc => 'colB'}] | ORDER BY colA, colB ASC
+ |
+ { -asc => [qw/colA colB] } | ORDER BY colA ASC, colB ASC
+ |
+ [ |
+ { -asc => 'colA' }, | ORDER BY colA ASC, colB DESC,
+ { -desc => [qw/colB/], | colC ASC, colD ASC
+ { -asc => [qw/colC colD/],|
+ ] |
+ ===========================================================
@@ -2266,6 +2321,7 @@
Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by)
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)
Thanks!
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=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/lib/SQL/Abstract/Test.pm (original)
+++ trunk/libsql-abstract-perl/lib/SQL/Abstract/Test.pm Thu Apr 30 09:44:58 2009
@@ -13,6 +13,7 @@
$case_sensitive $sql_differ/;
our $case_sensitive = 0;
+our $parenthesis_significant = 0;
our $sql_differ; # keeps track of differing portion between SQLs
our $tb = __PACKAGE__->builder;
@@ -203,68 +204,8 @@
# both are an op-list combo
else {
- for my $ast ($left, $right) {
-
- next unless (ref $ast->[1]);
-
- # unroll parenthesis in an elaborate loop
- my $changes;
- do {
-
- my @children;
- $changes = 0;
-
- for my $child (@{$ast->[1]}) {
- if (not ref $child or not $child->[0] eq 'PAREN') {
- push @children, $child;
- next;
- }
-
- # unroll nested parenthesis
- while ($child->[1][0][0] eq 'PAREN') {
- $child = $child->[1][0];
- $changes++;
- }
-
- # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
- if (
- ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
- and
- $child->[1][0][0] eq $ast->[0]
- ) {
- push @children, @{$child->[1][0][1]};
- $changes++;
- }
-
- # if the parent operator explcitly allows it nuke the parenthesis
- elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
- push @children, $child->[1][0];
- $changes++;
- }
-
- # only one element in the parenthesis which is a binary op with two EXPR 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'
- and
- $child->[1][0][1][1][0] eq 'EXPR'
- ) {
- push @children, $child->[1][0];
- $changes++;
- }
-
- # otherwise no more mucking for this pass
- else {
- push @children, $child;
- }
- }
-
- $ast->[1] = \@children;
- } while ($changes);
- }
+ # unroll parenthesis if possible/allowed
+ _parenthesis_unroll ($_) for ($left, $right);
# if operators are different
if ($left->[0] ne $right->[0]) {
@@ -290,7 +231,6 @@
}
}
}
-
sub parse {
my $s = shift;
@@ -378,7 +318,70 @@
}
}
-
+sub _parenthesis_unroll {
+ my $ast = shift;
+
+ return if $parenthesis_significant;
+ return unless (ref $ast and ref $ast->[1]);
+
+ my $changes;
+ do {
+ my @children;
+ $changes = 0;
+
+ for my $child (@{$ast->[1]}) {
+ if (not ref $child or not $child->[0] eq 'PAREN') {
+ push @children, $child;
+ next;
+ }
+
+ # unroll nested parenthesis
+ while ($child->[1][0][0] eq 'PAREN') {
+ $child = $child->[1][0];
+ $changes++;
+ }
+
+ # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
+ if (
+ ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
+ and
+ $child->[1][0][0] eq $ast->[0]
+ ) {
+ push @children, @{$child->[1][0][1]};
+ $changes++;
+ }
+
+ # if the parent operator explcitly allows it nuke the parenthesis
+ elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
+ push @children, $child->[1][0];
+ $changes++;
+ }
+
+ # only one element in the parenthesis which is a binary op with two EXPR 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'
+ and
+ $child->[1][0][1][1][0] eq 'EXPR'
+ ) {
+ push @children, $child->[1][0];
+ $changes++;
+ }
+
+ # otherwise no more mucking for this pass
+ else {
+ push @children, $child;
+ }
+ }
+
+ $ast->[1] = \@children;
+
+ } while ($changes);
+
+}
sub unparse {
my $tree = shift;
@@ -520,6 +523,11 @@
If true, SQL comparisons will be case-sensitive. Default is false;
+=head2 $parenthesis_significant
+
+If true, SQL comparison will preserve and report difference in nested
+parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
+
=head2 $sql_differ
When L</eq_sql> returns false, the global variable
@@ -537,6 +545,8 @@
Norbert Buchmuller <norbi at nix.hu>
+Peter Rabbitson <ribasushi at cpan.org>
+
=head1 COPYRIGHT AND LICENSE
Copyright 2008 by Laurent Dami.
Modified: trunk/libsql-abstract-perl/t/04modifiers.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/t/04modifiers.t?rev=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/t/04modifiers.t (original)
+++ trunk/libsql-abstract-perl/t/04modifiers.t Thu Apr 30 09:44:58 2009
@@ -145,7 +145,6 @@
},
# test column multi-cond in arrayref (even more useful)
{
- todo => 'Clarify semantics in 1.52',
where => { x => { '!=' => [ -and => (1 .. 3) ] } },
stmt => 'WHERE x != ? AND x != ? AND x != ?',
bind => [1..3],
@@ -153,12 +152,11 @@
# the -or should affect only the inner hashref, as we are not in an outer arrayref
{
- todo => 'Clarify semantics in 1.52',
where => { x => {
-or => { '!=', 1, '>=', 2 }, -like => 'x%'
}},
- stmt => 'WHERE (x != ? OR x >= ?) AND x LIKE ?',
- bind => [qw/1 2 x%/],
+ stmt => 'WHERE x LIKE ? AND ( x != ? OR x >= ? )',
+ bind => [qw/x% 1 2/],
},
# the -and should affect the OUTER arrayref, while the internal structures remain intact
@@ -340,7 +338,40 @@
},
);
-plan tests => @and_or_tests*3 + @numbered_mods*4;
+my @nest_tests = (
+ {
+ where => {a => 1, -nest => [b => 2, c => 3]},
+ stmt => 'WHERE ( ( (b = ? OR c = ?) AND a = ? ) )',
+ bind => [qw/2 3 1/],
+ },
+ {
+ where => {a => 1, -nest => {b => 2, c => 3}},
+ stmt => 'WHERE ( ( (b = ? AND c = ?) AND a = ? ) )',
+ bind => [qw/2 3 1/],
+ },
+ {
+ where => {a => 1, -or => {-nest => {b => 2, c => 3}}},
+ stmt => 'WHERE ( ( (b = ? AND c = ?) AND a = ? ) )',
+ bind => [qw/2 3 1/],
+ },
+ {
+ where => {a => 1, -or => {-nest => [b => 2, c => 3]}},
+ stmt => 'WHERE ( ( (b = ? OR c = ?) AND a = ? ) )',
+ bind => [qw/2 3 1/],
+ },
+ {
+ where => {a => 1, -nest => {-or => {b => 2, c => 3}}},
+ stmt => 'WHERE ( ( (c = ? OR b = ?) AND a = ? ) )',
+ bind => [qw/3 2 1/],
+ },
+ {
+ where => [a => 1, -nest => {b => 2, c => 3}, -nest => [d => 4, e => 5]],
+ stmt => 'WHERE ( ( a = ? OR ( b = ? AND c = ? ) OR ( d = ? OR e = ? ) ) )',
+ bind => [qw/1 2 3 4 5/],
+ },
+);
+
+plan tests => @and_or_tests*3 + @numbered_mods*4 + @nest_tests*2;
for my $case (@and_or_tests) {
TODO: {
@@ -366,8 +397,34 @@
}
}
+for my $case (@nest_tests) {
+ TODO: {
+ local $TODO = $case->{todo} if $case->{todo};
+
+ local $SQL::Abstract::Test::parenthesis_significant = 1;
+ local $Data::Dumper::Terse = 1;
+
+ 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};
+ });
+ }
+}
+
+
+
my $w_str = "\QUse of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0\E";
for my $case (@numbered_mods) {
+ TODO: {
+ local $TODO = $case->{todo} if $case->{todo};
+
local $Data::Dumper::Terse = 1;
my @w;
@@ -395,5 +452,6 @@
is (@non_match, 0, 'All warnings match the deprecation message')
|| diag join "\n", 'Rogue warnings:', @non_match;
+ }
}
Modified: trunk/libsql-abstract-perl/t/06order_by.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/t/06order_by.t?rev=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/t/06order_by.t (original)
+++ trunk/libsql-abstract-perl/t/06order_by.t Thu Apr 30 09:44:58 2009
@@ -3,6 +3,7 @@
use strict;
use warnings;
use Test::More;
+use Test::Exception;
use SQL::Abstract;
@@ -59,10 +60,36 @@
expects => '',
expects_quoted => '',
},
+
+ {
+ given => [{-desc => [ qw/colA colB/ ] }],
+ expects => ' ORDER BY colA DESC, colB DESC',
+ expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC',
+ },
+ {
+ given => [{-desc => [ qw/colA colB/ ] }, {-asc => 'colC'}],
+ expects => ' ORDER BY colA DESC, colB DESC, colC ASC',
+ expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC, `colC` ASC',
+ },
+ {
+ given => [{-desc => [ qw/colA colB/ ] }, {-asc => [ qw/colC colD/ ] }],
+ expects => ' ORDER BY colA DESC, colB DESC, colC ASC, colD ASC',
+ expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC, `colC` ASC, `colD` ASC',
+ },
+ {
+ given => [{-desc => [ qw/colA colB/ ] }, {-desc => 'colC' }],
+ expects => ' ORDER BY colA DESC, colB DESC, colC DESC',
+ expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC, `colC` DESC',
+ },
+ {
+ given => [{ -asc => 'colA' }, { -desc => [qw/colB/] }, { -asc => [qw/colC colD/] }],
+ expects => ' ORDER BY colA ASC, colB DESC, colC ASC, colD ASC',
+ expects_quoted => ' ORDER BY `colA` ASC, `colB` DESC, `colC` ASC, `colD` ASC',
+ },
);
-plan tests => (scalar(@cases) * 2);
+plan tests => (scalar(@cases) * 2) + 2;
my $sql = SQL::Abstract->new;
my $sqlq = SQL::Abstract->new({quote_char => '`'});
@@ -71,3 +98,15 @@
is($sql->_order_by($case->{given}), $case->{expects});
is($sqlq->_order_by($case->{given}), $case->{expects_quoted});
}
+
+throws_ok (
+ sub { $sql->_order_by({-desc => 'colA', -asc => 'colB' }) },
+ qr/hash passed .+ must have exactly one key/,
+ 'Undeterministic order exception',
+);
+
+throws_ok (
+ sub { $sql->_order_by({-desc => [ qw/colA colB/ ], -asc => [ qw/colC colD/ ] }) },
+ qr/hash passed .+ must have exactly one key/,
+ 'Undeterministic order exception',
+);
Modified: trunk/libsql-abstract-perl/t/07subqueries.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/t/07subqueries.t?rev=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/t/07subqueries.t (original)
+++ trunk/libsql-abstract-perl/t/07subqueries.t Thu Apr 30 09:44:58 2009
@@ -1,105 +1,105 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use Test::More;
-
-use SQL::Abstract::Test import => ['is_same_sql_bind'];
-
-use SQL::Abstract;
-
-my $sql = SQL::Abstract->new;
-
-my (@tests, $sub_stmt, @sub_bind, $where);
-
-#1
-($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
- 100, "foo%");
-$where = {
- foo => 1234,
- bar => \["IN ($sub_stmt)" => @sub_bind],
- };
-push @tests, {
- where => $where,
- stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )",
- bind => [100, "foo%", 1234],
-};
-
-#2
-($sub_stmt, @sub_bind)
- = $sql->select("t1", "c1", {c2 => {"<" => 100},
- c3 => {-like => "foo%"}});
-$where = {
- foo => 1234,
- bar => \["> ALL ($sub_stmt)" => @sub_bind],
- };
-push @tests, {
- where => $where,
- stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE ( c2 < ? AND c3 LIKE ? )) AND foo = ? )",
- bind => [100, "foo%", 1234],
-};
-
-#3
-($sub_stmt, @sub_bind)
- = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
-$where = {
- foo => 1234,
- -nest => \["EXISTS ($sub_stmt)" => @sub_bind],
- };
-push @tests, {
- where => $where,
- stmt => " WHERE ( EXISTS (SELECT * FROM t1 WHERE ( c1 = ? AND c2 > t0.c0 )) AND foo = ? )",
- bind => [1, 1234],
-};
-
-#4
-$where = {
- -nest => \["MATCH (col1, col2) AGAINST (?)" => "apples"],
- };
-push @tests, {
- where => $where,
- stmt => " WHERE ( MATCH (col1, col2) AGAINST (?) )",
- bind => ["apples"],
-};
-
-
-#5
-($sub_stmt, @sub_bind)
- = $sql->where({age => [{"<" => 10}, {">" => 20}]});
-$sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
-$where = {
- lname => {-like => '%son%'},
- -nest => \["NOT ( $sub_stmt )" => @sub_bind],
- };
-push @tests, {
- where => $where,
- stmt => " WHERE ( NOT ( ( ( ( age < ? ) OR ( age > ? ) ) ) ) AND lname LIKE ? )",
- bind => [10, 20, '%son%'],
-};
-
-#6
-($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
- 100, "foo%");
-$where = {
- foo => 1234,
- bar => { -in => \[$sub_stmt => @sub_bind] },
- };
-push @tests, {
- where => $where,
- stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )",
- bind => [100, "foo%", 1234],
-};
-
-
-plan tests => scalar(@tests);
-
-for (@tests) {
-
- my($stmt, @bind) = $sql->where($_->{where}, $_->{order});
- is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind});
-}
-
-
-
-
-
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
+
+use SQL::Abstract;
+
+my $sql = SQL::Abstract->new;
+
+my (@tests, $sub_stmt, @sub_bind, $where);
+
+#1
+($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
+ 100, "foo%");
+$where = {
+ foo => 1234,
+ bar => \["IN ($sub_stmt)" => @sub_bind],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )",
+ bind => [100, "foo%", 1234],
+};
+
+#2
+($sub_stmt, @sub_bind)
+ = $sql->select("t1", "c1", {c2 => {"<" => 100},
+ c3 => {-like => "foo%"}});
+$where = {
+ foo => 1234,
+ bar => \["> ALL ($sub_stmt)" => @sub_bind],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE ( c2 < ? AND c3 LIKE ? )) AND foo = ? )",
+ bind => [100, "foo%", 1234],
+};
+
+#3
+($sub_stmt, @sub_bind)
+ = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
+$where = {
+ foo => 1234,
+ -nest => \["EXISTS ($sub_stmt)" => @sub_bind],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( EXISTS (SELECT * FROM t1 WHERE ( c1 = ? AND c2 > t0.c0 )) AND foo = ? )",
+ bind => [1, 1234],
+};
+
+#4
+$where = {
+ -nest => \["MATCH (col1, col2) AGAINST (?)" => "apples"],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( MATCH (col1, col2) AGAINST (?) )",
+ bind => ["apples"],
+};
+
+
+#5
+($sub_stmt, @sub_bind)
+ = $sql->where({age => [{"<" => 10}, {">" => 20}]});
+$sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
+$where = {
+ lname => {-like => '%son%'},
+ -nest => \["NOT ( $sub_stmt )" => @sub_bind],
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( NOT ( ( ( ( age < ? ) OR ( age > ? ) ) ) ) AND lname LIKE ? )",
+ bind => [10, 20, '%son%'],
+};
+
+#6
+($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
+ 100, "foo%");
+$where = {
+ foo => 1234,
+ bar => { -in => \[$sub_stmt => @sub_bind] },
+ };
+push @tests, {
+ where => $where,
+ stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )",
+ bind => [100, "foo%", 1234],
+};
+
+
+plan tests => scalar(@tests);
+
+for (@tests) {
+
+ my($stmt, @bind) = $sql->where($_->{where}, $_->{order});
+ is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind});
+}
+
+
+
+
+
Modified: trunk/libsql-abstract-perl/t/08special_ops.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/t/08special_ops.t?rev=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/t/08special_ops.t (original)
+++ trunk/libsql-abstract-perl/t/08special_ops.t Thu Apr 30 09:44:58 2009
@@ -1,69 +1,69 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use Test::More;
-
-use SQL::Abstract::Test import => ['is_same_sql_bind'];
-
-use SQL::Abstract;
-
-my $sqlmaker = SQL::Abstract->new(special_ops => [
-
- # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
- {regex => qr/^match$/i,
- handler => sub {
- my ($self, $field, $op, $arg) = @_;
- $arg = [$arg] if not ref $arg;
- my $label = $self->_quote($field);
- my ($placeholder) = $self->_convert('?');
- my $placeholders = join ", ", (($placeholder) x @$arg);
- my $sql = $self->_sqlcase('match') . " ($label) "
- . $self->_sqlcase('against') . " ($placeholders) ";
- my @bind = $self->_bindtype($field, @$arg);
- return ($sql, @bind);
- }
- },
-
- # special op for Basis+ NATIVE
- {regex => qr/^native$/i,
- handler => sub {
- my ($self, $field, $op, $arg) = @_;
- $arg =~ s/'/''/g;
- my $sql = "NATIVE (' $field $arg ')";
- return ($sql);
- }
- },
-
-]);
-
-my @tests = (
-
- #1
- { where => {foo => {-match => 'foo'},
- bar => {-match => [qw/foo bar/]}},
- stmt => " WHERE ( MATCH (bar) AGAINST (?, ?) AND MATCH (foo) AGAINST (?) )",
- bind => [qw/foo bar foo/],
- },
-
- #2
- { where => {foo => {-native => "PH IS 'bar'"}},
- stmt => " WHERE ( NATIVE (' foo PH IS ''bar'' ') )",
- bind => [],
- },
-
-);
-
-
-plan tests => scalar(@tests);
-
-for (@tests) {
-
- my($stmt, @bind) = $sqlmaker->where($_->{where}, $_->{order});
- is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind});
-}
-
-
-
-
-
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
+
+use SQL::Abstract;
+
+my $sqlmaker = SQL::Abstract->new(special_ops => [
+
+ # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
+ {regex => qr/^match$/i,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ $arg = [$arg] if not ref $arg;
+ my $label = $self->_quote($field);
+ my ($placeholder) = $self->_convert('?');
+ my $placeholders = join ", ", (($placeholder) x @$arg);
+ my $sql = $self->_sqlcase('match') . " ($label) "
+ . $self->_sqlcase('against') . " ($placeholders) ";
+ my @bind = $self->_bindtype($field, @$arg);
+ return ($sql, @bind);
+ }
+ },
+
+ # special op for Basis+ NATIVE
+ {regex => qr/^native$/i,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ $arg =~ s/'/''/g;
+ my $sql = "NATIVE (' $field $arg ')";
+ return ($sql);
+ }
+ },
+
+]);
+
+my @tests = (
+
+ #1
+ { where => {foo => {-match => 'foo'},
+ bar => {-match => [qw/foo bar/]}},
+ stmt => " WHERE ( MATCH (bar) AGAINST (?, ?) AND MATCH (foo) AGAINST (?) )",
+ bind => [qw/foo bar foo/],
+ },
+
+ #2
+ { where => {foo => {-native => "PH IS 'bar'"}},
+ stmt => " WHERE ( NATIVE (' foo PH IS ''bar'' ') )",
+ bind => [],
+ },
+
+);
+
+
+plan tests => scalar(@tests);
+
+for (@tests) {
+
+ my($stmt, @bind) = $sqlmaker->where($_->{where}, $_->{order});
+ is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind});
+}
+
+
+
+
+
Modified: trunk/libsql-abstract-perl/t/09refkind.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/t/09refkind.t?rev=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/t/09refkind.t (original)
+++ trunk/libsql-abstract-perl/t/09refkind.t Thu Apr 30 09:44:58 2009
@@ -1,31 +1,31 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use Test::More;
-use SQL::Abstract;
-
-plan tests => 13;
-
-my $obj = bless {}, "Foo::Bar";
-
-is(SQL::Abstract->_refkind(undef), 'UNDEF', 'UNDEF');
-
-is(SQL::Abstract->_refkind({}), 'HASHREF', 'HASHREF');
-is(SQL::Abstract->_refkind([]), 'ARRAYREF', 'ARRAYREF');
-
-is(SQL::Abstract->_refkind(\{}), 'HASHREFREF', 'HASHREFREF');
-is(SQL::Abstract->_refkind(\[]), 'ARRAYREFREF', 'ARRAYREFREF');
-
-is(SQL::Abstract->_refkind(\\{}), 'HASHREFREFREF', 'HASHREFREFREF');
-is(SQL::Abstract->_refkind(\\[]), 'ARRAYREFREFREF', 'ARRAYREFREFREF');
-
-is(SQL::Abstract->_refkind("foo"), 'SCALAR', 'SCALAR');
-is(SQL::Abstract->_refkind(\"foo"), 'SCALARREF', 'SCALARREF');
-is(SQL::Abstract->_refkind(\\"foo"), 'SCALARREFREF', 'SCALARREFREF');
-
-# objects are treated like scalars
-is(SQL::Abstract->_refkind($obj), 'SCALAR', 'SCALAR');
-is(SQL::Abstract->_refkind(\$obj), 'SCALARREF', 'SCALARREF');
-is(SQL::Abstract->_refkind(\\$obj), 'SCALARREFREF', 'SCALARREFREF');
-
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use SQL::Abstract;
+
+plan tests => 13;
+
+my $obj = bless {}, "Foo::Bar";
+
+is(SQL::Abstract->_refkind(undef), 'UNDEF', 'UNDEF');
+
+is(SQL::Abstract->_refkind({}), 'HASHREF', 'HASHREF');
+is(SQL::Abstract->_refkind([]), 'ARRAYREF', 'ARRAYREF');
+
+is(SQL::Abstract->_refkind(\{}), 'HASHREFREF', 'HASHREFREF');
+is(SQL::Abstract->_refkind(\[]), 'ARRAYREFREF', 'ARRAYREFREF');
+
+is(SQL::Abstract->_refkind(\\{}), 'HASHREFREFREF', 'HASHREFREFREF');
+is(SQL::Abstract->_refkind(\\[]), 'ARRAYREFREFREF', 'ARRAYREFREFREF');
+
+is(SQL::Abstract->_refkind("foo"), 'SCALAR', 'SCALAR');
+is(SQL::Abstract->_refkind(\"foo"), 'SCALARREF', 'SCALARREF');
+is(SQL::Abstract->_refkind(\\"foo"), 'SCALARREFREF', 'SCALARREFREF');
+
+# objects are treated like scalars
+is(SQL::Abstract->_refkind($obj), 'SCALAR', 'SCALAR');
+is(SQL::Abstract->_refkind(\$obj), 'SCALARREF', 'SCALARREF');
+is(SQL::Abstract->_refkind(\\$obj), 'SCALARREFREF', 'SCALARREFREF');
+
Modified: trunk/libsql-abstract-perl/t/10test.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/t/10test.t?rev=34389&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/t/10test.t (original)
+++ trunk/libsql-abstract-perl/t/10test.t Thu Apr 30 09:44:58 2009
@@ -5,6 +5,17 @@
use List::Util qw(sum);
use Test::More;
+
+# equivalent to $Module::Install::AUTHOR
+my $author = (
+ ( not -d './inc' )
+ or
+ ( -e ($^O eq 'VMS' ? './inc/_author' : './inc/.author') )
+);
+
+if (not $author and not $ENV{SQLATEST_TESTER} and not $ENV{AUTOMATED_TESTING}) {
+ plan skip_all => 'Skipping resource intensive self-tests, use SQLATEST_TESTER=1 to run';
+}
my @sql_tests = (
@@ -101,6 +112,7 @@
equal => 1,
statements => [
q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND c = 1/,
+ q/SELECT foo FROM bar WHERE (a = 1 AND b = 1 AND c = 1)/,
q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) AND c = 1/,
q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 AND c = 1)/,
q/SELECT foo FROM bar WHERE ((((a = 1))) AND (b = 1 AND c = 1))/,
@@ -117,6 +129,36 @@
},
{
equal => 1,
+ statements => [
+ q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1 OR c = 1 OR d = 1) AND (e = 1 AND f = 1)/,
+ q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 OR c = 1 OR d = 1) AND e = 1 AND (f = 1)/,
+ q/SELECT foo FROM bar WHERE ( ((a = 1) AND ( b = 1 OR (c = 1 OR d = 1) )) AND ((e = 1)) AND f = 1) /,
+ ]
+ },
+ {
+ equal => 0,
+ parenthesis_significant => 1,
+ statements => [
+ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND c = 1/,
+ q/SELECT foo FROM bar WHERE (a = 1 AND b = 1 AND c = 1)/,
+ q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) AND c = 1/,
+ q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 AND c = 1)/,
+ q/SELECT foo FROM bar WHERE ((((a = 1))) AND (b = 1 AND c = 1))/,
+ ]
+ },
+ {
+ equal => 0,
+ parenthesis_significant => 1,
+ statements => [
+ q/SELECT foo FROM bar WHERE a = 1 OR b = 1 OR c = 1/,
+ q/SELECT foo FROM bar WHERE (a = 1 OR b = 1) OR c = 1/,
+ q/SELECT foo FROM bar WHERE a = 1 OR (b = 1 OR c = 1)/,
+ q/SELECT foo FROM bar WHERE a = 1 OR ((b = 1 OR (c = 1)))/,
+ ]
+ },
+ {
+ equal => 0,
+ parenthesis_significant => 1,
statements => [
q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1 OR c = 1 OR d = 1) AND (e = 1 AND f = 1)/,
q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 OR c = 1 OR d = 1) AND e = 1 AND (f = 1)/,
@@ -722,7 +764,12 @@
while (@$statements) {
my $sql1 = shift @$statements;
foreach my $sql2 (@$statements) {
+
+ no warnings qw/once/; # perl 5.10 is dumb
+ local $SQL::Abstract::Test::parenthesis_significant = $test->{parenthesis_significant}
+ if $test->{parenthesis_significant};
my $equal = eq_sql($sql1, $sql2);
+
TODO: {
local $TODO = $test->{todo} if $test->{todo};
More information about the Pkg-perl-cvs-commits
mailing list