First pass at adding key files
This commit is contained in:
dsainty
404
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Condition.pm
Normal file
404
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Condition.pm
Normal file
@ -0,0 +1,404 @@
|
||||
# ==================================================================
|
||||
# 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
|
||||
Reference in New Issue
Block a user