405 lines
12 KiB
Perl
405 lines
12 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Base
|
|
# Author: Scott Beck
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: Condition.pm,v 1.45 2006/02/16 20:26:14 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Implements an SQL condition.
|
|
#
|
|
|
|
package GT::SQL::Condition;
|
|
# ===============================================================
|
|
use GT::Base;
|
|
use GT::AutoLoader;
|
|
use strict;
|
|
use vars qw/@ISA $ERROR_MESSAGE $VERSION/;
|
|
|
|
@ISA = qw/GT::Base/;
|
|
$ERROR_MESSAGE = 'GT::SQL';
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.45 $ =~ /(\d+)\.(\d+)/;
|
|
|
|
sub new {
|
|
# -----------------------------------------------------------------------------
|
|
# CLASS->new;
|
|
# $obj->new;
|
|
# ----------
|
|
# This class method is the base constructor for the GT::SQL::Condition
|
|
# object. It can be passed the boolean operator that has to be used for that
|
|
# object ("AND" is the default), the conditions for this object.
|
|
#
|
|
my $class = shift;
|
|
$class = ref $class || $class;
|
|
my $self = {
|
|
cond => [],
|
|
not => 0,
|
|
bool => 'AND'
|
|
};
|
|
bless $self, $class;
|
|
|
|
if (@_ and defined $_[-1] and (uc $_[-1] eq 'AND' or uc $_[-1] eq 'OR' or $_[-1] eq ',') ) {
|
|
$self->boolean(uc pop);
|
|
}
|
|
$self->add(@_) if @_;
|
|
return $self;
|
|
}
|
|
|
|
$COMPILE{clone} = __LINE__ . <<'END_OF_SUB';
|
|
sub clone {
|
|
# -----------------------------------------------------------------------------
|
|
# Clones the current object - that is, gives you an identical object that
|
|
# doesn't reference the original at all.
|
|
#
|
|
my $self = shift;
|
|
my $newself = { not => $self->{not}, bool => $self->{bool} };
|
|
bless $newself, ref $self;
|
|
my @cond;
|
|
|
|
for (@{$self->{cond}}) {
|
|
# {cond} can contain two things - three-value array references
|
|
# ('COL', '=', 'VAL'), or full-fledged condition objects.
|
|
if (ref eq 'ARRAY') {
|
|
push @cond, [@$_];
|
|
}
|
|
elsif (UNIVERSAL::isa($_, __PACKAGE__)) {
|
|
push @cond, $_->clone;
|
|
}
|
|
}
|
|
$newself->{cond} = \@cond;
|
|
$newself;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{not} = __LINE__ . <<'END_OF_SUB';
|
|
sub not {
|
|
# -----------------------------------------------------------------------------
|
|
# $obj->not;
|
|
# ----------------
|
|
# Negates the current condition.
|
|
#
|
|
$_[0]->{not} = 1;
|
|
return $_[0];
|
|
}
|
|
END_OF_SUB
|
|
|
|
|
|
$COMPILE{new_clean} = __LINE__ . <<'END_OF_SUB';
|
|
sub new_clean {
|
|
# -----------------------------------------------------------------------------
|
|
# $obj->new_clean;
|
|
# ----------------
|
|
# Returns the same condition object, but ready to be prepared again.
|
|
#
|
|
my $self = shift;
|
|
my $class = ref $self;
|
|
my $res = $class->new;
|
|
$res->boolean($self->boolean);
|
|
for my $cond (@{$self->{cond}}) {
|
|
$res->add($cond);
|
|
}
|
|
return $res;
|
|
}
|
|
END_OF_SUB
|
|
|
|
sub boolean {
|
|
# -----------------------------------------------------------------------------
|
|
# $obj->boolean;
|
|
# --------------
|
|
# Returns the boolean operator which is being used for the current object.
|
|
#
|
|
# $obj->boolean($string);
|
|
# ------------------------
|
|
# Sets $string as the boolean operator for this condition object. Typically
|
|
# this should be nothing else than "AND" or "OR", but no checks are
|
|
# performed, so watch out for typos!
|
|
#
|
|
my $self = shift;
|
|
$self->{bool} = shift || return $self->{bool};
|
|
}
|
|
|
|
sub add {
|
|
# -----------------------------------------------------------------------------
|
|
# $obj->add($col => $op => $val [, $col2 => $op2 => $val2, ...]);
|
|
# ----------------------------
|
|
# Adds a one or more COL OP VAL clauses to the current condition.
|
|
#
|
|
# $obj->add($condition [, $cond2, ...]);
|
|
# -----------------------
|
|
# Adds one or more condition clauses to the current condition.
|
|
#
|
|
my $self = shift;
|
|
|
|
while (@_) {
|
|
my $var = shift;
|
|
if (ref $var eq 'ARRAY' or UNIVERSAL::isa($var, __PACKAGE__)) {
|
|
push @{$self->{cond}}, $var;
|
|
}
|
|
elsif (ref $var eq 'HASH') {
|
|
for (keys %$var) {
|
|
push @{$self->{cond}}, [$_ => '=' => $var->{$_}];
|
|
}
|
|
}
|
|
else {
|
|
my $op = @_ >= 2 ? shift || '=' : '='; # To support $cond->add(foo => $bar);
|
|
my $val = shift;
|
|
if (not defined $val) {
|
|
if ($op eq '=' and $self->{bool} ne ',') {
|
|
$op = 'IS';
|
|
}
|
|
elsif ($op eq '!=' or $op eq '<>') {
|
|
$op = 'IS NOT';
|
|
}
|
|
}
|
|
push @{$self->{cond}}, [$var => $op => $val];
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub sql {
|
|
# -----------------------------------------------------------------------------
|
|
# Returns a string for the current SQL object which is the SQL representation
|
|
# of that condition. The string can then be inserted after a SQL WHERE clause.
|
|
# Optionally takes an option which, if true, uses placeholders and returns
|
|
# ($sql, \@values, \@columns) instead of just $sql.
|
|
#
|
|
my ($self, $ph) = @_;
|
|
my $bool = $self->{bool};
|
|
my (@vals, @cols, @output);
|
|
|
|
foreach my $cond (@{$self->{cond}}) {
|
|
if (ref $cond eq 'ARRAY') {
|
|
my ($col, $op, $val) = @$cond;
|
|
# Perl: column => '=' => [1,2,3]
|
|
# SQL: column IN (1,2,3)
|
|
if (uc $op eq 'IN' || $op eq '=' and ref $val eq 'ARRAY') {
|
|
if (@$val > 1) {
|
|
$op = 'IN';
|
|
$val = '('
|
|
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
|
|
. ')';
|
|
}
|
|
elsif (@$val == 0) {
|
|
($col, $op, $val) = (qw(1 = 0));
|
|
}
|
|
else {
|
|
$op = '=';
|
|
$val = quote($val->[0]);
|
|
}
|
|
push @output, "$col $op $val";
|
|
}
|
|
# Perl: column => '!=' => [1,2,3]
|
|
# SQL: NOT(column IN (1,2,3))
|
|
elsif ($op eq '!=' || $op eq '<>' and ref $val eq 'ARRAY') {
|
|
my $output;
|
|
if (@$val > 1) {
|
|
$output = "NOT ($col IN ";
|
|
$output .= '('
|
|
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
|
|
. ')';
|
|
$output .= ')';
|
|
}
|
|
elsif (@$val == 0) {
|
|
$output = '1 = 1';
|
|
}
|
|
else {
|
|
$output = "$col $op " . quote($val->[0]);
|
|
}
|
|
push @output, $output;
|
|
}
|
|
elsif ($ph and defined $val and not ref $val) {
|
|
push @output, "$col $op ?";
|
|
push @cols, $col;
|
|
push @vals, $val;
|
|
}
|
|
else {
|
|
push @output, "$col $op " . quote($val);
|
|
}
|
|
}
|
|
elsif (UNIVERSAL::isa($cond, __PACKAGE__)) {
|
|
my @sql = $cond->sql($ph);
|
|
if ($sql[0]) {
|
|
push @output, "($sql[0])";
|
|
if ($ph) {
|
|
push @vals, @{$sql[1]};
|
|
push @cols, @{$sql[2]};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
my $final = join " $bool ", @output;
|
|
$final &&= "NOT ($final)" if $self->{not};
|
|
|
|
return wantarray ? ($final, $ph ? (\@vals, \@cols) : ()) : $final;
|
|
}
|
|
|
|
$COMPILE{sql_ph} = __LINE__ . <<'END_OF_SUB';
|
|
sub sql_ph {
|
|
# -----------------------------------------------------------------------------
|
|
# Depreciated form of ->sql(1);
|
|
shift->sql(1);
|
|
}
|
|
END_OF_SUB
|
|
|
|
sub quote {
|
|
# -----------------------------------------------------------------------------
|
|
# this subroutines quotes (or not) a value given its column.
|
|
#
|
|
defined(my $val = pop) or return 'NULL';
|
|
return ref $val eq 'SCALAR' ? $$val : GT::SQL::Driver->quote($val);
|
|
}
|
|
|
|
sub as_hash {
|
|
# -----------------------------------------------------------------------------
|
|
# returns the condition object as a flattened hash.
|
|
#
|
|
my $cond = shift;
|
|
ref $cond eq 'HASH' and return $cond;
|
|
my %ret;
|
|
for my $arr (@{$cond->{cond}}) {
|
|
if (ref $arr eq 'ARRAY') {
|
|
$ret{$arr->[0]} = $arr->[2];
|
|
}
|
|
else {
|
|
my $h = as_hash($arr);
|
|
for my $k (keys %$h) {
|
|
$ret{$k} = $h->{$k};
|
|
}
|
|
}
|
|
}
|
|
return \%ret;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::SQL::Condition - Creates complex where clauses
|
|
|
|
=head1 SYNOPSYS
|
|
|
|
my $cond = GT::SQL::Condition->new(Column => LIKE => 'foo%');
|
|
print $cond->sql;
|
|
|
|
my $cond = GT::SQL::Condition->new(
|
|
Column => LIKE => 'foo%',
|
|
Column2 => '<' => 'abc'
|
|
);
|
|
$cond->bool('OR');
|
|
print $cond->sql;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
The condition module is useful for generating complex SQL WHERE clauses. At
|
|
it's simplest, a condition is composed of three parts: column, condition and
|
|
value.
|
|
|
|
Here are some examples.
|
|
|
|
To find all users with a first name that starts with Alex use:
|
|
|
|
my $cond = GT::SQL::Condition->new(FirstName => LIKE => 'Alex%');
|
|
|
|
To find users with first name like alex, B<and> last name like krohn use:
|
|
|
|
my $cond = GT::SQL::Condition->new(
|
|
FirstName => LIKE => 'Alex%',
|
|
LastName => LIKE => 'Krohn%'
|
|
);
|
|
|
|
To find users with first name like alex B<or> last name like krohn use:
|
|
|
|
my $cond = GT::SQL::Condition->new(
|
|
FirstName => LIKE => 'Alex%',
|
|
LastName => LIKE => 'Krohn%'
|
|
);
|
|
$cond->bool('OR');
|
|
|
|
You may also specify this as:
|
|
|
|
my $cond = GT::SQL::Condition->new(
|
|
FirstName => LIKE => 'Alex%',
|
|
LastName => LIKE => 'Krohn%',
|
|
'OR'
|
|
);
|
|
|
|
Now say we wanted something a bit more complex that would normally involve
|
|
setting parentheses. We want to find users who have either first name like alex
|
|
or last name like krohn, and whose employer is Gossamer Threads. We could use:
|
|
|
|
my $cond1 = GT::SQL::Condition->new(
|
|
'FirstName', 'LIKE', 'Alex%',
|
|
'LastName', 'LIKE', 'Krohn%'
|
|
);
|
|
$cond1->bool('or');
|
|
my $cond2 = GT::SQL::Condition->new(
|
|
$cond1,
|
|
Employer => '=' => 'Gossamer Threads'
|
|
);
|
|
|
|
By default, all values are quoted, so you don't need to bother using any quote
|
|
function. If you don't want something quoted (say you want to use a function
|
|
for example), then you pass in a reference.
|
|
|
|
For example, to find users who have a last name that sounds like 'krohn', you
|
|
could use your SQL engines SOUNDEX function:
|
|
|
|
my $cond = GT::SQL::Condition->new(LastName => '=' => \"SOUNDEX('krohn')");
|
|
|
|
and the right side wouldn't be quoted.
|
|
|
|
You can also use a condition object to specify a list of multiple values, which
|
|
will become the SQL 'IN' operator. For example, to match anyone with a first
|
|
name of Alex, Scott or Jason, you can do:
|
|
|
|
my $cond = GT::SQL::Condition->new(FirstName => IN => ['Alex', 'Scott', 'Jason']);
|
|
|
|
which will turn into:
|
|
|
|
FirstName IN ('Alex', 'Scott', 'Jason')
|
|
|
|
Note that when using multiple values, you can use '=' instead of 'IN'. Empty
|
|
lists will be treated as an impossible condition (1 = 0). This is primarily
|
|
useful for list handling list of id numbers.
|
|
|
|
To match NULL values, you can use C<undef> for the value passed to the add()
|
|
method. If specifying '=' as the operator, it will automatically be changed to
|
|
'IS':
|
|
|
|
$cond->add(MiddleName => '=' => undef);
|
|
|
|
becomes:
|
|
|
|
MiddleName IS NULL
|
|
|
|
|
|
To negate your queries you can use the C<not> function.
|
|
|
|
my $cond = GT::SQL::Condition->new(a => '=' => 5);
|
|
$cond->not;
|
|
|
|
would translate into NOT (a = '5'). You can also do this all on one line like:
|
|
|
|
print GT::SQL::Condition->new(a => '=' => '5')->not->sql;
|
|
|
|
This returns the sql right away.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Condition.pm,v 1.45 2006/02/16 20:26:14 jagerman Exp $
|
|
|
|
=cut
|