[Bast-commits] r7347 - in SQL-Abstract/1.x/branches/fix_nesting: .
lib/SQL t
ribasushi at dev.catalyst.perl.org
ribasushi at dev.catalyst.perl.org
Thu Aug 20 08:10:52 GMT 2009
Author: ribasushi
Date: 2009-08-20 08:10:52 +0000 (Thu, 20 Aug 2009)
New Revision: 7347
Modified:
SQL-Abstract/1.x/branches/fix_nesting/
SQL-Abstract/1.x/branches/fix_nesting/Changes
SQL-Abstract/1.x/branches/fix_nesting/Makefile.PL
SQL-Abstract/1.x/branches/fix_nesting/lib/SQL/Abstract.pm
SQL-Abstract/1.x/branches/fix_nesting/t/04modifiers.t
SQL-Abstract/1.x/branches/fix_nesting/t/06order_by.t
Log:
r6166 at Thesaurus (orig r6165): ribasushi | 2009-05-07 19:18:03 +0200
r6156 at Thesaurus (orig r6155): ribasushi | 2009-05-07 09:28:09 +0200
New branch to allow special op overriding
r6159 at Thesaurus (orig r6158): ribasushi | 2009-05-07 11:55:12 +0200
Allow special op handlers to be a method name alongside a coderef
Switch built-in -in/-between handling to the method calling scheme, to facilitate overriding
r6168 at Thesaurus (orig r6167): ribasushi | 2009-05-07 19:23:04 +0200
Release 1.54
r6291 at Thesaurus (orig r6290): ribasushi | 2009-05-17 00:45:12 +0200
Test and fix for obscure where-cond modification
r6292 at Thesaurus (orig r6291): ribasushi | 2009-05-17 01:25:10 +0200
Release 1.55
r6453 at Thesaurus (orig r6452): mo | 2009-05-29 15:41:22 +0200
added failing test for -desc => \['colA LIKE ?', 'test']
r6454 at Thesaurus (orig r6453): ribasushi | 2009-05-29 17:41:10 +0200
Fix for _order_by with bind values - will not work on DBIC - needs matching changes to SQLAHacks
r6455 at Thesaurus (orig r6454): mo | 2009-05-29 18:28:54 +0200
order_by: added passing test
r6461 at Thesaurus (orig r6460): ribasushi | 2009-05-30 10:10:38 +0200
Do not join hash order conditions early
r6466 at Thesaurus (orig r6465): ribasushi | 2009-05-30 18:35:46 +0200
Release 1.56
Property changes on: SQL-Abstract/1.x/branches/fix_nesting
___________________________________________________________________
Name: svk:merge
- b9bda2dc-4395-4011-945f-8c81d782bde1:/branches/matthewt:18
b9bda2dc-4395-4011-945f-8c81d782bde1:/trunk:23
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/branches/and_or:6008
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/trunk/SQL-Abstract:3093
+ b9bda2dc-4395-4011-945f-8c81d782bde1:/branches/matthewt:18
b9bda2dc-4395-4011-945f-8c81d782bde1:/trunk:23
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/branches/and_or:6008
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/branches/special_op_handling:6158
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/SQL-Abstract/1.x/trunk:6465
bd8105ee-0ff8-0310-8827-fb3f25b6796d:/trunk/SQL-Abstract:3093
Modified: SQL-Abstract/1.x/branches/fix_nesting/Changes
===================================================================
--- SQL-Abstract/1.x/branches/fix_nesting/Changes 2009-08-20 07:49:05 UTC (rev 7346)
+++ SQL-Abstract/1.x/branches/fix_nesting/Changes 2009-08-20 08:10:52 UTC (rev 7347)
@@ -1,5 +1,20 @@
Revision history for SQL::Abstract
+revision 1.56 2009-05-30 16:31 (UTC)
+----------------------------
+ - support for \[$sql, @bind] in order_by clauses e.g.:
+ { -desc => \['colA LIKE ?', 'somestring'] }
+
+revision 1.55 2009-05-17 22:54 (UTC)
+----------------------------
+ - make sure that sql generation does not mutate the supplied
+ where condition structure
+
+revision 1.54 2009-05-07 17:23 (UTC)
+----------------------------
+ - allow special_operators to take both code refs and method names
+ (makes it possible to properly subclass the builtin ones)
+
revision 1.53 2009-04-30 14:58 (UTC)
----------------------------
- make sure hash keys are sorted in all search sub-conditions
Modified: SQL-Abstract/1.x/branches/fix_nesting/Makefile.PL
===================================================================
--- SQL-Abstract/1.x/branches/fix_nesting/Makefile.PL 2009-08-20 07:49:05 UTC (rev 7346)
+++ SQL-Abstract/1.x/branches/fix_nesting/Makefile.PL 2009-08-20 08:10:52 UTC (rev 7347)
@@ -18,6 +18,7 @@
test_requires "Test::More" => 0;
test_requires "Test::Exception" => 0;
test_requires "Test::Warn" => 0;
+test_requires "Clone" => 0.31;
tests_recursive 't';
Modified: SQL-Abstract/1.x/branches/fix_nesting/lib/SQL/Abstract.pm
===================================================================
--- SQL-Abstract/1.x/branches/fix_nesting/lib/SQL/Abstract.pm 2009-08-20 07:49:05 UTC (rev 7346)
+++ SQL-Abstract/1.x/branches/fix_nesting/lib/SQL/Abstract.pm 2009-08-20 08:10:52 UTC (rev 7347)
@@ -15,7 +15,7 @@
# GLOBALS
#======================================================================
-our $VERSION = '1.53';
+our $VERSION = '1.56';
# This would confuse some packagers
#$VERSION = eval $VERSION; # numify for warning-free dev releases
@@ -25,8 +25,8 @@
# special operators (-in, -between). May be extended/overridden by user.
# See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
my @BUILTIN_SPECIAL_OPS = (
- {regex => qr/^(not )?between$/i, handler => \&_where_field_BETWEEN},
- {regex => qr/^(not )?in$/i, handler => \&_where_field_IN},
+ {regex => qr/^(not )?between$/i, handler => '_where_field_BETWEEN'},
+ {regex => qr/^(not )?in$/i, handler => '_where_field_IN'},
);
#======================================================================
@@ -553,7 +553,19 @@
# CASE: special operators like -in or -between
my $special_op = first {$op =~ $_->{regex}} @{$self->{special_ops}};
if ($special_op) {
- ($sql, @bind) = $special_op->{handler}->($self, $k, $op, $val);
+ my $handler = $special_op->{handler};
+ if (! $handler) {
+ puke "No handler supplied for special operator matching $special_op->{regex}";
+ }
+ elsif (not ref $handler) {
+ ($sql, @bind) = $self->$handler ($k, $op, $val);
+ }
+ elsif (ref $handler eq 'CODE') {
+ ($sql, @bind) = $handler->($self, $k, $op, $val);
+ }
+ else {
+ puke "Illegal handler for special operator matching $special_op->{regex} - expecting a method name or a coderef";
+ }
}
else {
$self->_SWITCH_refkind($val, {
@@ -608,18 +620,20 @@
sub _where_field_op_ARRAYREF {
my ($self, $k, $op, $vals) = @_;
- if(@$vals) {
- $self->_debug("ARRAY($vals) means multiple elements: [ @$vals ]");
+ my @vals = @$vals; #always work on a copy
+ 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) {
+ if ($vals[0] =~ /^ - ( AND|OR ) $/ix) {
$logic = uc $1;
- shift @$vals;
+ shift @vals;
}
- # distribute $op over each remaining member of @$vals, append logic if exists
- return $self->_recurse_where([map { {$k => {$op, $_}} } @$vals], $logic);
+ # 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 :
@@ -628,7 +642,7 @@
# WHERE field != 22 AND field != 33.
# 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);
+ # return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
}
else {
@@ -804,50 +818,78 @@
sub _order_by {
my ($self, $arg) = @_;
- # construct list of ordering instructions
- my @order = $self->_SWITCH_refkind($arg, {
+ my (@sql, @bind);
+ for my $c ($self->_order_by_chunks ($arg) ) {
+ $self->_SWITCH_refkind ($c, {
+ SCALAR => sub { push @sql, $c },
+ ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
+ });
+ }
+ my $sql = @sql
+ ? sprintf ('%s %s',
+ $self->_sqlcase(' order by'),
+ join (', ', @sql)
+ )
+ : ''
+ ;
+
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+sub _order_by_chunks {
+ my ($self, $arg) = @_;
+
+ return $self->_SWITCH_refkind($arg, {
+
ARRAYREF => sub {
- map {$self->_SWITCH_refkind($_, {
- SCALAR => sub {$self->_quote($_)},
- UNDEF => sub {},
- SCALARREF => sub {$$_}, # literal SQL, no quoting
- HASHREF => sub {$self->_order_by_hash($_)}
- }) } @$arg;
+ map { $self->_order_by_chunks ($_ ) } @$arg;
},
+ ARRAYREFREF => sub { [ @$$arg ] },
+
SCALAR => sub {$self->_quote($arg)},
- UNDEF => sub {},
+
+ UNDEF => sub {return () },
+
SCALARREF => sub {$$arg}, # literal SQL, no quoting
- HASHREF => sub {$self->_order_by_hash($arg)},
- });
+ HASHREF => sub {
+ # get first pair in hash
+ my ($key, $val) = each %$arg;
- # build SQL
- my $order = join ', ', @order;
- return $order ? $self->_sqlcase(' order by')." $order" : '';
-}
+ return () unless $key;
+ if ( (keys %$arg) > 1 or not $key =~ /^-(desc|asc)/i ) {
+ puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
+ }
-sub _order_by_hash {
- my ($self, $hash) = @_;
+ my $direction = $1;
- # get first pair in hash
- my ($key, $val) = each %$hash;
+ my @ret;
+ for my $c ($self->_order_by_chunks ($val)) {
+ my ($sql, @bind);
- # check if one pair was found and no other pair in hash
- $key && !(each %$hash)
- or puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
+ $self->_SWITCH_refkind ($c, {
+ SCALAR => sub {
+ $sql = $c;
+ },
+ ARRAYREF => sub {
+ ($sql, @bind) = @$c;
+ },
+ });
- my ($order) = ($key =~ /^-(desc|asc)/i)
- or puke "invalid key in _order_by hash : $key";
+ $sql = $sql . ' ' . $self->_sqlcase($direction);
- $val = ref $val eq 'ARRAY' ? $val : [$val];
- return join ', ', map { $self->_quote($_) . ' ' . $self->_sqlcase($order) } @$val;
+ push @ret, [ $sql, @bind];
+ }
+
+ return @ret;
+ },
+ });
}
-
#======================================================================
# DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
#======================================================================
@@ -2128,12 +2170,17 @@
=head1 SPECIAL OPERATORS
my $sqlmaker = SQL::Abstract->new(special_ops => [
- {regex => qr/.../,
+ {
+ regex => qr/.../,
handler => sub {
my ($self, $field, $op, $arg) = @_;
...
- },
+ },
},
+ {
+ regex => qr/.../,
+ handler => 'method_name',
+ },
]);
A "special operator" is a SQL syntactic clause that can be
@@ -2145,12 +2192,13 @@
WHERE MATCH(field) AGAINST (?, ?)
Special operators IN and BETWEEN are fairly standard and therefore
-are builtin within C<SQL::Abstract>. For other operators,
-like the MATCH .. AGAINST example above which is
-specific to MySQL, you can write your own operator handlers :
-supply a C<special_ops> argument to the C<new> method.
-That argument takes an arrayref of operator definitions;
-each operator definition is a hashref with two entries
+are builtin within C<SQL::Abstract> (as the overridable methods
+C<_where_field_IN> and C<_where_field_BETWEEN>). For other operators,
+like the MATCH .. AGAINST example above which is specific to MySQL,
+you can write your own operator handlers - supply a C<special_ops>
+argument to the C<new> method. That argument takes an arrayref of
+operator definitions; each operator definition is a hashref with two
+entries:
=over
@@ -2160,11 +2208,25 @@
=item handler
-coderef that will be called when meeting that operator
-in the input tree. The coderef will be called with
-arguments C<< ($self, $field, $op, $arg) >>, and
-should return a C<< ($sql, @bind) >> structure.
+Either a coderef or a plain scalar method name. In both cases
+the expected return is C<< ($sql, @bind) >>.
+When supplied with a method name, it is simply called on the
+L<SQL::Abstract/> object as:
+
+ $self->$method_name ($field, $op, $arg)
+
+ Where:
+
+ $op is the part that matched the handler regex
+ $field is the LHS of the operator
+ $arg is the RHS
+
+When supplied with a coderef, it is called as:
+
+ $coderef->($self, $field, $op, $arg)
+
+
=back
For example, here is an implementation
Modified: SQL-Abstract/1.x/branches/fix_nesting/t/04modifiers.t
===================================================================
--- SQL-Abstract/1.x/branches/fix_nesting/t/04modifiers.t 2009-08-20 07:49:05 UTC (rev 7346)
+++ SQL-Abstract/1.x/branches/fix_nesting/t/04modifiers.t 2009-08-20 08:10:52 UTC (rev 7347)
@@ -8,6 +8,7 @@
use Data::Dumper;
use SQL::Abstract;
+use Clone;
=begin
Test -and -or modifiers, assuming the following:
@@ -372,7 +373,7 @@
},
);
-plan tests => @and_or_tests*3 + @backcompat_mods*4 + @paren_tests*2;
+plan tests => @and_or_tests*4 + @backcompat_mods*4 + @paren_tests*2;
for my $case (@and_or_tests) {
TODO: {
@@ -382,7 +383,10 @@
my @w;
local $SIG{__WARN__} = sub { push @w, @_ };
+
my $sql = SQL::Abstract->new ($case->{args} || {});
+ my $where_copy = Clone::clone ($case->{where});
+
lives_ok (sub {
my ($stmt, @bind) = $sql->where($case->{where});
is_same_sql_bind(
@@ -395,6 +399,8 @@
});
is (@w, 0, 'No warnings within and-or tests')
|| diag join "\n", 'Emitted warnings:', @w;
+
+ is_deeply ($case->{where}, $where_copy, 'Where conditions unchanged');
}
}
Modified: SQL-Abstract/1.x/branches/fix_nesting/t/06order_by.t
===================================================================
--- SQL-Abstract/1.x/branches/fix_nesting/t/06order_by.t 2009-08-20 07:49:05 UTC (rev 7346)
+++ SQL-Abstract/1.x/branches/fix_nesting/t/06order_by.t 2009-08-20 08:10:52 UTC (rev 7347)
@@ -86,6 +86,24 @@
expects => ' ORDER BY colA ASC, colB DESC, colC ASC, colD ASC',
expects_quoted => ' ORDER BY `colA` ASC, `colB` DESC, `colC` ASC, `colD` ASC',
},
+ {
+ given => { -desc => \['colA LIKE ?', 'test'] },
+ expects => ' ORDER BY colA LIKE ? DESC',
+ expects_quoted => ' ORDER BY colA LIKE ? DESC',
+ bind => ['test'],
+ },
+ {
+ given => \['colA LIKE ? DESC', 'test'],
+ expects => ' ORDER BY colA LIKE ? DESC',
+ expects_quoted => ' ORDER BY colA LIKE ? DESC',
+ bind => ['test'],
+ },
+ {
+ given => [ { -asc => \['colA'] }, { -desc => \['colB LIKE ?', 'test'] }, { -asc => \['colC LIKE ?', 'tost'] }],
+ expects => ' ORDER BY colA ASC, colB LIKE ? DESC, colC LIKE ? ASC',
+ expects_quoted => ' ORDER BY colA ASC, colB LIKE ? DESC, colC LIKE ? ASC',
+ bind => [qw/test tost/],
+ },
);
@@ -94,9 +112,24 @@
my $sql = SQL::Abstract->new;
my $sqlq = SQL::Abstract->new({quote_char => '`'});
-for my $case( @cases){
- is($sql->_order_by($case->{given}), $case->{expects});
- is($sqlq->_order_by($case->{given}), $case->{expects_quoted});
+for my $case( @cases) {
+ my ($stat, @bind);
+
+ ($stat, @bind) = $sql->_order_by($case->{given});
+ is_same_sql_bind (
+ $stat,
+ \@bind,
+ $case->{expects},
+ $case->{bind} || [],
+ );
+
+ ($stat, @bind) = $sqlq->_order_by($case->{given});
+ is_same_sql_bind (
+ $stat,
+ \@bind,
+ $case->{expects_quoted},
+ $case->{bind} || [],
+ );
}
throws_ok (
More information about the Bast-commits
mailing list