# GLOBALS
#======================================================================
-our $VERSION = '1.51';
+our $VERSION = '1.56';
# This would confuse some packagers
#$VERSION = eval $VERSION; # numify for warning-free dev releases
# 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'},
);
#======================================================================
my ($self, $where) = @_;
my (@sql_clauses, @all_bind);
- # LDNOTE : don't really know why we need to sort keys
for my $k (sort keys %$where) {
my $v = $where->{$k};
HASHREF => sub {
if ($op eq 'OR') {
- return $self->_where_ARRAYREF([%$v], 'OR');
+ return $self->_where_ARRAYREF([ map { $_ => $v->{$_} } (sort keys %$v) ], 'OR');
}
else { # NEST | AND
return $self->_where_HASHREF($v);
$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;
}
sub _where_hashpair_HASHREF {
- my ($self, $k, $v) = @_;
+ my ($self, $k, $v, $logic) = @_;
+ $logic ||= 'and';
- my (@all_sql, @all_bind);
+ my ($all_sql, @all_bind);
for my $op (sort keys %$v) {
my $val = $v->{$op};
# 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, {
@bind = @sub_bind;
},
+ HASHREF => sub {
+ ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $op);
+ },
+
UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
my $is = ($op =~ $self->{equality_op}) ? 'is' :
($op =~ $self->{inequality_op}) ? 'is not' :
});
}
- 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);
}
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) {
+ $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);
+ # 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
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)";
+ }
+
+ my $direction = $1;
-sub _order_by_hash {
- my ($self, $hash) = @_;
+ my @ret;
+ for my $c ($self->_order_by_chunks ($val)) {
+ my ($sql, @bind);
- # get first pair in hash
- my ($key, $val) = each %$hash;
+ $self->_SWITCH_refkind ($c, {
+ SCALAR => sub {
+ $sql = $c;
+ },
+ ARRAYREF => sub {
+ ($sql, @bind) = @$c;
+ },
+ });
- # 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)";
+ $sql = $sql . ' ' . $self->_sqlcase($direction);
- my ($order) = ($key =~ /^-(desc|asc)/i)
- or puke "invalid key in _order_by hash : $key";
+ push @ret, [ $sql, @bind];
+ }
- return $self->_quote($val) ." ". $self->_sqlcase($order);
+ return @ret;
+ },
+ });
}
-
#======================================================================
# DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
#======================================================================
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/],|
+ ] |
+ ===========================================================
=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',
},
]);
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
=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
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!
C<SQL::Abstract>, and as such list members there are very familiar with
how to create queries.
+=head1 LICENSE
+
This module is free software; you may copy this under the terms of
the GNU General Public License, or the Artistic License, copies of
which should have accompanied your Perl kit.
projects / scpubgit/Q-Branch.git / blobdiff