r43634 - in /trunk/libsql-abstract-perl: ./ debian/ inc/Module/ inc/Module/Install/ lib/SQL/ t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Fri Sep 4 03:52:19 UTC 2009
Author: jawnsy-guest
Date: Fri Sep 4 03:52:01 2009
New Revision: 43634
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=43634
Log:
* New upstream release
+ Adds -bool and -not_bool operators
* Standards-Version 3.8.3 (no changes)
* Update copyright information including M::I clause
* Rewrite control description
* Add myself to Uploaders and Copyright
Added:
trunk/libsql-abstract-perl/t/90pod.t
- copied unchanged from r43633, branches/upstream/libsql-abstract-perl/current/t/90pod.t
trunk/libsql-abstract-perl/t/91podcoverage.t
- copied unchanged from r43633, branches/upstream/libsql-abstract-perl/current/t/91podcoverage.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/debian/control
trunk/libsql-abstract-perl/debian/copyright
trunk/libsql-abstract-perl/debian/rules
trunk/libsql-abstract-perl/inc/Module/Install.pm
trunk/libsql-abstract-perl/inc/Module/Install/Base.pm
trunk/libsql-abstract-perl/inc/Module/Install/Can.pm
trunk/libsql-abstract-perl/inc/Module/Install/Fetch.pm
trunk/libsql-abstract-perl/inc/Module/Install/Makefile.pm
trunk/libsql-abstract-perl/inc/Module/Install/Metadata.pm
trunk/libsql-abstract-perl/inc/Module/Install/Win32.pm
trunk/libsql-abstract-perl/inc/Module/Install/WriteAll.pm
trunk/libsql-abstract-perl/lib/SQL/Abstract.pm
trunk/libsql-abstract-perl/t/02where.t
Modified: trunk/libsql-abstract-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/Changes?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/Changes (original)
+++ trunk/libsql-abstract-perl/Changes Fri Sep 4 03:52:01 2009
@@ -1,4 +1,8 @@
Revision history for SQL::Abstract
+
+revision 1.57 2009-09-03 20:18 (UTC)
+----------------------------
+ - added -bool and -not_bool operators
revision 1.56 2009-05-30 16:31 (UTC)
----------------------------
Modified: trunk/libsql-abstract-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/MANIFEST?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/MANIFEST (original)
+++ trunk/libsql-abstract-perl/MANIFEST Fri Sep 4 03:52:01 2009
@@ -24,3 +24,5 @@
t/08special_ops.t
t/09refkind.t
t/10test.t
+t/90pod.t
+t/91podcoverage.t
Modified: trunk/libsql-abstract-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/META.yml?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/META.yml (original)
+++ trunk/libsql-abstract-perl/META.yml Fri Sep 4 03:52:01 2009
@@ -13,7 +13,7 @@
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.90'
+generated_by: 'Module::Install version 0.91'
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.56
+version: 1.57
Modified: trunk/libsql-abstract-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/debian/changelog?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/debian/changelog (original)
+++ trunk/libsql-abstract-perl/debian/changelog Fri Sep 4 03:52:01 2009
@@ -1,10 +1,19 @@
-libsql-abstract-perl (1.56-2) UNRELEASED; urgency=low
+libsql-abstract-perl (1.57-1) UNRELEASED; urgency=low
+ [ Jonathan Yu ]
+ * New upstream release
+ + Adds -bool and -not_bool operators
+ * Standards-Version 3.8.3 (no changes)
+ * Update copyright information including M::I clause
+ * Rewrite control description
+ * Add myself to Uploaders and Copyright
+
+ [ Salvatore Bonaccorso ]
* debian/control: Changed: Replace versioned (build-)dependency on
perl (>= 5.6.0-{12,16}) with an unversioned dependency on perl (as
permitted by Debian Policy 3.8.3).
- -- Salvatore Bonaccorso <salvatore.bonaccorso at gmail.com> Sun, 16 Aug 2009 20:15:46 +0200
+ -- Jonathan Yu <jawnsy at cpan.org> Thu, 03 Sep 2009 19:36:15 -0400
libsql-abstract-perl (1.56-1) unstable; urgency=low
Modified: trunk/libsql-abstract-perl/debian/control
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/debian/control?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/debian/control (original)
+++ trunk/libsql-abstract-perl/debian/control Fri Sep 4 03:52:01 2009
@@ -1,13 +1,14 @@
Source: libsql-abstract-perl
Section: perl
Priority: optional
+Build-Depends: debhelper (>= 7.2.13)
+Build-Depends-Indep: perl, libtest-deep-perl, libtest-exception-perl,
+ libtest-warn-perl, libclone-perl (>= 0.31)
Maintainer: Debian Perl Group <pkg-perl-maintainers at lists.alioth.debian.org>
Uploaders: Krzysztof Krzyżaniak (eloy) <eloy at debian.org>,
- gregor herrmann <gregoa at debian.org>, Ansgar Burchardt <ansgar at 43-1.org>
-Build-Depends: debhelper (>= 7.2.13)
-Build-Depends-Indep: perl, libtest-deep-perl,
- libtest-exception-perl, libtest-warn-perl, libclone-perl (>=0.31)
-Standards-Version: 3.8.1
+ gregor herrmann <gregoa at debian.org>, Ansgar Burchardt <ansgar at 43-1.org>,
+ Jonathan Yu <jawnsy at cpan.org>
+Standards-Version: 3.8.3
Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libsql-abstract-perl/
Vcs-Browser: http://svn.debian.org/viewsvn/pkg-perl/trunk/libsql-abstract-perl/
Homepage: http://search.cpan.org/dist/SQL-Abstract/
@@ -16,16 +17,14 @@
Architecture: all
Depends: ${perl:Depends}, ${misc:Depends}
Description: Perl module to generate SQL from Perl data structures
- SQL::Abstract module was inspired by the DBIx::Abstract. The intention of this
- module is to provide abstract SQL generation methods. With this module
- you can generate SQL, but still retain complete control over the
- statement handles and use the DBI interface if you wish.
+ SQL::Abstract is a Perl module that allows developers to genreate SQL from
+ Perl data strutures, inspired by DBIx::Abstract. The intent of this module
+ is to provide abstract SQL generation methods, allowing one to generate SQL
+ while retaining complete control over the statement handles.
.
- While based on the concepts used by DBIx::Abstract, there are several
- important differences, especially when it comes to WHERE
- clauses. Some of the concepts used have been modified to make the SQL
- easier to generate from Perl data structures and hopefully more
- intuitive. The underlying idea is for this module to do what you
- mean, based on the data structures you provide it. The big advantage
- is that you don't have to modify your code every time your data
- changes, as this module figures it out.
+ There are many important differences between this module and DBIx::Abstract,
+ especially when it comes to WHERE clauses. Chief among these changes is a
+ new design to make it easier to generate SQL from Perl data structures and
+ hopefully more intuitive. The underlying idea is that this module does what
+ you mean, based on the data structures you provide it; the biggest advantage
+ is that you don't have to modify your code every time your data changes.
Modified: trunk/libsql-abstract-perl/debian/copyright
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/debian/copyright?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/debian/copyright (original)
+++ trunk/libsql-abstract-perl/debian/copyright Fri Sep 4 03:52:01 2009
@@ -5,27 +5,29 @@
Upstream-Name: SQL-Abstract
Files: *
-Copyright: © 2001-2007 Nathan Wiger
- © 2007-2009 Matt Trout <mst at shadowcat.co.uk>
-License-Alias: Perl
-License: GPL-1+ | Artistic
-
-Files: inc/*
-Copyright: © 2008 - 2009 Adam Kennedy
+Copyright: 2007-2009, Matt Trout <mst at shadowcat.co.uk>
+ 2001-2007, Nathan Wiger <nwiger at cpan.org>
License-Alias: Perl
License: GPL-1+ | Artistic
Files: lib/SQL/Abstract/Test.pm
-Copyright: 2008, Laurent Dami, <laurent.dami AT etat geneve ch>
+Copyright: 2008, Laurent Dami <laurent.dami at etat.geneve.ch>
License-Alias: Perl
License: GPL-1+ | Artistic
Files: debian/*
-Copyright:
- © 2003-2006 Stephen Quinney <sjq at debian.org>
- © 2006-2008 Bart Martens <bartm at debian.org>
- © 2009 Krzysztof Krzyzaniak (eloy) <eloy at debian.org>
- © 2009 gregor herrmann <gregoa at debian.org>
+Copyright: 2009, Jonathan Yu <jawnsy at cpan.org>
+ 2009, Krzysztof Krzyzaniak (eloy) <eloy at debian.org>
+ 2009, gregor herrmann <gregoa at debian.org>
+ 2006-2008, Bart Martens <bartm at debian.org>
+ 2003-2006, Stephen Quinney <sjq at debian.org>
+License: Artistic | GPL-1+
+
+Files: inc/Module/*
+Copyright: 2002-2009, Adam Kennedy <adamk at cpan.org>
+ 2002-2009, Audrey Tang <autrijus at autrijus.org>
+ 2002-2009, Brian Ingerson <ingy at cpan.org>
+License-Alias: Perl
License: Artistic | GPL-1+
License: Artistic
Modified: trunk/libsql-abstract-perl/debian/rules
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/debian/rules?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/debian/rules (original)
+++ trunk/libsql-abstract-perl/debian/rules Fri Sep 4 03:52:01 2009
@@ -1,3 +1,4 @@
#!/usr/bin/make -f
+
%:
dh $@
Modified: trunk/libsql-abstract-perl/inc/Module/Install.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/inc/Module/Install.pm?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/inc/Module/Install.pm (original)
+++ trunk/libsql-abstract-perl/inc/Module/Install.pm Fri Sep 4 03:52:01 2009
@@ -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.90';
+ $VERSION = '0.91';
# Storage for the pseudo-singleton
$MAIN = undef;
Modified: trunk/libsql-abstract-perl/inc/Module/Install/Base.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/inc/Module/Install/Base.pm?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/inc/Module/Install/Base.pm (original)
+++ trunk/libsql-abstract-perl/inc/Module/Install/Base.pm Fri Sep 4 03:52:01 2009
@@ -4,7 +4,7 @@
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.90';
+ $VERSION = '0.91';
}
# Suspend handler for "redefined" warnings
Modified: trunk/libsql-abstract-perl/inc/Module/Install/Can.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/inc/Module/Install/Can.pm?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/inc/Module/Install/Can.pm (original)
+++ trunk/libsql-abstract-perl/inc/Module/Install/Can.pm Fri Sep 4 03:52:01 2009
@@ -9,7 +9,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.90';
+ $VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
Modified: trunk/libsql-abstract-perl/inc/Module/Install/Fetch.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/inc/Module/Install/Fetch.pm?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/inc/Module/Install/Fetch.pm (original)
+++ trunk/libsql-abstract-perl/inc/Module/Install/Fetch.pm Fri Sep 4 03:52:01 2009
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.90';
+ $VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
Modified: trunk/libsql-abstract-perl/inc/Module/Install/Makefile.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/inc/Module/Install/Makefile.pm?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/inc/Module/Install/Makefile.pm (original)
+++ trunk/libsql-abstract-perl/inc/Module/Install/Makefile.pm Fri Sep 4 03:52:01 2009
@@ -7,7 +7,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.90';
+ $VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
Modified: trunk/libsql-abstract-perl/inc/Module/Install/Metadata.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/inc/Module/Install/Metadata.pm?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/inc/Module/Install/Metadata.pm (original)
+++ trunk/libsql-abstract-perl/inc/Module/Install/Metadata.pm Fri Sep 4 03:52:01 2009
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.90';
+ $VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -505,6 +505,17 @@
}
}
+sub test_requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->test_requires( $module => $version );
+ }
+}
+
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
Modified: trunk/libsql-abstract-perl/inc/Module/Install/Win32.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/inc/Module/Install/Win32.pm?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/inc/Module/Install/Win32.pm (original)
+++ trunk/libsql-abstract-perl/inc/Module/Install/Win32.pm Fri Sep 4 03:52:01 2009
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.90';
+ $VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
Modified: trunk/libsql-abstract-perl/inc/Module/Install/WriteAll.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/inc/Module/Install/WriteAll.pm?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/inc/Module/Install/WriteAll.pm (original)
+++ trunk/libsql-abstract-perl/inc/Module/Install/WriteAll.pm Fri Sep 4 03:52:01 2009
@@ -6,7 +6,7 @@
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.90';;
+ $VERSION = '0.91';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
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=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/lib/SQL/Abstract.pm (original)
+++ trunk/libsql-abstract-perl/lib/SQL/Abstract.pm Fri Sep 4 03:52:01 2009
@@ -15,7 +15,7 @@
# GLOBALS
#======================================================================
-our $VERSION = '1.56';
+our $VERSION = '1.57';
# This would confuse some packagers
#$VERSION = eval $VERSION; # numify for warning-free dev releases
@@ -29,6 +29,15 @@
{regex => qr/^(not )?in$/i, handler => '_where_field_IN'},
);
+# unaryish operators - key maps to handler
+my @BUILTIN_UNARY_OPS = (
+ # the digits are backcompat stuff
+ { regex => qr/^and (?: \s? \d+ )? $/xi, handler => '_where_op_ANDOR' },
+ { regex => qr/^or (?: \s? \d+ )? $/xi, handler => '_where_op_ANDOR' },
+ { regex => qr/^nest (?: \s? \d+ )? $/xi, handler => '_where_op_NEST' },
+ { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
+);
+
#======================================================================
# DEBUGGING AND ERROR REPORTING
#======================================================================
@@ -85,6 +94,10 @@
# special operators
$opt{special_ops} ||= [];
push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
+
+ # unary operators
+ $opt{unary_ops} ||= [];
+ push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
return bless \%opt, $class;
}
@@ -426,7 +439,7 @@
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)
+ 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);
@@ -441,49 +454,90 @@
sub _where_op_in_hash {
- my ($self, $op_str, $v) = @_;
-
- $op_str =~ /^ (AND|OR|NEST) ( \_? \d* ) $/xi
- or puke "unknown operator: -$op_str";
-
- my $op = uc($1); # uppercase, remove trailing digits
- if ($2) {
- belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
- . "You probably wanted ...-and => [ $op_str => COND1, $op_str => COND2 ... ]";
+ 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";
}
-
- $self->_debug("OP(-$op) within hashref, recursing...");
+ 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_op_ANDOR {
+ my ($self, $op, $v) = @_;
$self->_SWITCH_refkind($v, {
-
ARRAYREF => sub {
- return $self->_where_ARRAYREF($v, $op eq 'NEST' ? '' : $op);
+ return $self->_where_ARRAYREF($v, $op);
},
HASHREF => sub {
- if ($op eq 'OR') {
- return $self->_where_ARRAYREF([ map { $_ => $v->{$_} } (sort keys %$v) ], 'OR');
- }
- else { # NEST | AND
- return $self->_where_HASHREF($v);
- }
+ return ( $op =~ /^or/i )
+ ? $self->_where_ARRAYREF( [ map { $_ => $v->{$_} } ( sort keys %$v ) ], $op )
+ : $self->_where_HASHREF($v);
},
+ SCALARREF => sub {
+ puke "-$op => \\\$scalar not supported, use -nest => ...";
+ },
+
+ ARRAYREFREF => sub {
+ puke "-$op => \\[..] not supported, use -nest => ...";
+ },
+
+ SCALAR => sub { # permissively interpreted as SQL
+ puke "-$op => 'scalar' not supported, use -nest => \\'scalar'";
+ },
+
+ UNDEF => sub {
+ puke "-$op => undef not supported";
+ },
+ });
+}
+
+sub _where_op_NEST {
+ my ($self, $op, $v) = @_;
+
+ $self->_SWITCH_refkind($v, {
+
+ ARRAYREF => sub {
+ return $self->_where_ARRAYREF($v, '');
+ },
+
+ HASHREF => sub {
+ return $self->_where_HASHREF($v);
+ },
+
SCALARREF => sub { # literal SQL
- $op eq 'NEST'
- or puke "-$op => \\\$scalar not supported, use -nest => ...";
return ($$v);
},
ARRAYREFREF => sub { # literal SQL
- $op eq 'NEST'
- or puke "-$op => \\[..] not supported, use -nest => ...";
return @{${$v}};
},
SCALAR => sub { # permissively interpreted as SQL
- $op eq 'NEST'
- or puke "-$op => 'scalar' not supported, use -nest => \\'scalar'";
belch "literal SQL should be -nest => \\'scalar' "
. "instead of -nest => 'scalar' ";
return ($v);
@@ -491,6 +545,22 @@
UNDEF => sub {
puke "-$op => undef not supported";
+ },
+ });
+}
+
+
+sub _where_op_BOOL {
+ my ($self, $op, $v) = @_;
+
+ my $prefix = ($op =~ /\bnot\b/i) ? 'NOT ' : '';
+ $self->_SWITCH_refkind($v, {
+ SCALARREF => sub { # literal SQL
+ return ($prefix . $$v);
+ },
+
+ SCALAR => sub { # interpreted as SQL column
+ return ($prefix . $self->_convert($self->_quote($v)));
},
});
}
@@ -533,15 +603,14 @@
my ($all_sql, @all_bind);
- for my $op (sort keys %$v) {
- my $val = $v->{$op};
+ for my $orig_op (sort keys %$v) {
+ my $val = $v->{$orig_op};
# put the operator in canonical form
- $op =~ s/^-//; # remove initial dash
- $op =~ tr/_/ /; # underscores become spaces
- $op =~ s/^\s+//; # no initial space
- $op =~ s/\s+$//; # no final space
- $op =~ s/\s+/ /; # multiple spaces become one
+ 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
my ($sql, @bind);
@@ -550,7 +619,7 @@
if ($special_op) {
my $handler = $special_op->{handler};
if (! $handler) {
- puke "No handler supplied for special operator matching $special_op->{regex}";
+ puke "No handler supplied for special operator $orig_op";
}
elsif (not ref $handler) {
($sql, @bind) = $self->$handler ($k, $op, $val);
@@ -559,7 +628,7 @@
($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";
+ puke "Illegal handler for special operator $orig_op - expecting a method name or a coderef";
}
}
else {
@@ -591,10 +660,10 @@
UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
my $is = ($op =~ $self->{equality_op}) ? 'is' :
($op =~ $self->{inequality_op}) ? 'is not' :
- puke "unexpected operator '$op' with undef operand";
+ puke "unexpected operator '$orig_op' with undef operand";
$sql = $self->_quote($k) . $self->_sqlcase(" $is null");
},
-
+
FALLBACK => sub { # CASE: col => {op => $scalar}
$sql = join ' ', $self->_convert($self->_quote($k)),
$self->_sqlcase($op),
@@ -800,8 +869,6 @@
return ($sql, @bind);
}
-
-
@@ -1549,6 +1616,12 @@
to extend the syntax understood by L<SQL::Abstract>.
See section L</"SPECIAL OPERATORS"> for details.
+=item unary_ops
+
+Takes a reference to a list of "unary operators"
+to extend the syntax understood by L<SQL::Abstract>.
+See section L</"UNARY OPERATORS"> for details.
+
=back
@@ -1868,6 +1941,24 @@
These are the two builtin "special operators"; but the
list can be expanded : see section L</"SPECIAL OPERATORS"> below.
+
+=head2 Unary operators: bool
+
+If you wish to test against boolean columns or functions within your
+database you can use the C<-bool> and C<-not_bool> operators. For
+example to test the column C<is_user> being true and the column
+<is_enabled> being false you would use:-
+
+ my %where = (
+ -bool => 'is_user',
+ -not_bool => 'is_enabled',
+ );
+
+Would give you:
+
+ WHERE is_user AND NOT is_enabled
+
+
=head2 Nested conditions, -and/-or prefixes
@@ -2247,6 +2338,59 @@
]);
+=head1 UNARY OPERATORS
+
+ my $sqlmaker = SQL::Abstract->new(unary_ops => [
+ {
+ regex => qr/.../,
+ handler => sub {
+ my ($self, $op, $arg) = @_;
+ ...
+ },
+ },
+ {
+ regex => qr/.../,
+ handler => 'method_name',
+ },
+ ]);
+
+A "unary operator" is a SQL syntactic clause that can be
+applied to a field - the operator goes before the field
+
+You can write your own operator handlers - supply a C<unary_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
+
+=item regex
+
+the regular expression to match the operator
+
+=item handler
+
+Either a coderef or a plain scalar method name. In both cases
+the expected return is C<< $sql >>.
+
+When supplied with a method name, it is simply called on the
+L<SQL::Abstract/> object as:
+
+ $self->$method_name ($op, $arg)
+
+ Where:
+
+ $op is the part that matched the handler regex
+ $arg is the RHS or argument of the operator
+
+When supplied with a coderef, it is called as:
+
+ $coderef->($self, $op, $arg)
+
+
+=back
+
+
=head1 PERFORMANCE
Thanks to some benchmarking by Mark Stosberg, it turns out that
Modified: trunk/libsql-abstract-perl/t/02where.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsql-abstract-perl/t/02where.t?rev=43634&op=diff
==============================================================================
--- trunk/libsql-abstract-perl/t/02where.t (original)
+++ trunk/libsql-abstract-perl/t/02where.t Fri Sep 4 03:52:01 2009
@@ -216,6 +216,55 @@
stmt => " WHERE (foo = ?)",
bind => [ "bar" ],
},
+
+ {
+ where => { -bool => \'function(x)' },
+ stmt => " WHERE function(x)",
+ bind => [],
+ },
+
+ {
+ where => { -bool => 'foo' },
+ stmt => " WHERE foo",
+ bind => [],
+ },
+
+ {
+ where => { -and => [-bool => 'foo', -bool => 'bar'] },
+ stmt => " WHERE foo AND bar",
+ bind => [],
+ },
+
+ {
+ where => { -or => [-bool => 'foo', -bool => 'bar'] },
+ stmt => " WHERE foo OR bar",
+ bind => [],
+ },
+
+ {
+ where => { -not_bool => \'function(x)' },
+ stmt => " WHERE NOT function(x)",
+ bind => [],
+ },
+
+ {
+ where => { -not_bool => 'foo' },
+ stmt => " WHERE NOT foo",
+ bind => [],
+ },
+
+ {
+ where => { -and => [-not_bool => 'foo', -not_bool => 'bar'] },
+ stmt => " WHERE NOT foo AND NOT bar",
+ bind => [],
+ },
+
+ {
+ where => { -or => [-not_bool => 'foo', -not_bool => 'bar'] },
+ stmt => " WHERE NOT foo OR NOT bar",
+ bind => [],
+ },
+
);
plan tests => ( @handle_tests * 2 ) + 1;
More information about the Pkg-perl-cvs-commits
mailing list