First pass at adding key files
This commit is contained in:
dsainty
607
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Base.pm
Normal file
607
site/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Base.pm
Normal file
@ -0,0 +1,607 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Table
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Base.pm,v 1.72 2011/05/13 23:56:51 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base class for GT::SQL::Table and GT::SQL::Relation
|
||||
#
|
||||
|
||||
package GT::SQL::Base;
|
||||
# ===============================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use strict;
|
||||
use vars qw($ERRORS $DEBUG @ISA $VERSION $ERROR_MESSAGE);
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.72 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
|
||||
# ============================================================================ #
|
||||
# TABLE ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
sub table {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a table or relation argument. Called with array of table names:
|
||||
# my $relation = $db->table('Links', 'CatLinks', 'Category');
|
||||
# my $table = $db->table('Links');
|
||||
#
|
||||
my ($self, @tables) = @_;
|
||||
|
||||
# Make sure we have a driver, and a list of tables were specified.
|
||||
$self->{connect} or return $self->fatal(NODATABASE => 'table()');
|
||||
@tables or return $self->fatal(BADARGS => 'Usage: $obj->table(@TABLES)');
|
||||
|
||||
for (@tables) { # Tables aren't passed to table() prefixed, so prefix them all.
|
||||
$_ = $self->{connect}->{PREFIX} . $_;
|
||||
}
|
||||
my $cache_key = join("\0", @tables, $self->{connect}->{def_path});
|
||||
$cache_key = (@tables > 1 ? "RELATION\0" : "TABLE\0") . $cache_key;
|
||||
$self->{cache} and exists $GT::SQL::OBJ_CACHE{$cache_key} and return $GT::SQL::OBJ_CACHE{$cache_key};
|
||||
|
||||
my $obj;
|
||||
if (@tables > 1) {
|
||||
$obj = $self->new_relation(@tables);
|
||||
}
|
||||
else {
|
||||
my $name = $self->{connect}->{def_path} . '/' . $tables[0] . '.def';
|
||||
(-e $name) or return $self->fatal(FILENOEXISTS => $name);
|
||||
$obj = $self->new_table($tables[0]);
|
||||
}
|
||||
# We don't need to worry about caching here - new_relation or new_table will add it to the cache.
|
||||
return $obj;
|
||||
}
|
||||
|
||||
# ============================================================================ #
|
||||
# EDITOR ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
$COMPILE{editor} = __LINE__ . <<'END_OF_SUB';
|
||||
sub editor {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns an editor object. Takes a table name as argument.
|
||||
# my $editor = $db->editor('Links')
|
||||
#
|
||||
my $self = shift;
|
||||
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->editor(\'tablename\')');
|
||||
|
||||
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'editor()');
|
||||
|
||||
my $table = $self->table($table_name);
|
||||
|
||||
# Set the error package to reflect the editor
|
||||
$table->{_err_pkg} = 'GT::SQL::Editor';
|
||||
$table->{_err_pkg} = 'GT::SQL::Editor';
|
||||
|
||||
# Get an editor object
|
||||
require GT::SQL::Editor;
|
||||
$self->debug("CREATING GT::SQL::Editor OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
return GT::SQL::Editor->new(
|
||||
debug => $self->{_debug},
|
||||
table => $table,
|
||||
connect => $self->{connect}
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prefix {
|
||||
my $self = shift;
|
||||
return $self->{connect}->{PREFIX};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub new_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates a table object for a single table.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $cache_key = "TABLE\0$table\0$self->{connect}->{def_path}";
|
||||
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
|
||||
$self->debug("Returning table object for $table from cache") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $cached;
|
||||
}
|
||||
|
||||
$self->debug("Creating new table object for $table") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
# Create a blank table object.
|
||||
my $table_obj = GT::SQL::Table->new(
|
||||
name => $table, # Already prefixed in schema
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Table'
|
||||
);
|
||||
|
||||
# Create a new object if we are subclassed.
|
||||
my $subclass = $table_obj->subclass;
|
||||
my $name = $table_obj->name;
|
||||
my $class = $subclass->{table}->{$name} || 'GT::SQL::Table';
|
||||
if ($subclass and $subclass->{table}->{$name}) {
|
||||
no strict 'refs';
|
||||
$self->_load_module($class) or return;
|
||||
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : {};
|
||||
foreach (keys %$errors) {
|
||||
$ERRORS->{$_} = $errors->{$_};
|
||||
}
|
||||
use strict 'refs';
|
||||
$table_obj = $class->new(
|
||||
name => $name, # Already prefixed in schema
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Table',
|
||||
_schema => $table_obj->{schema}
|
||||
);
|
||||
}
|
||||
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
|
||||
$GT::SQL::OBJ_CACHE{$cache_key} = $table_obj if $self->{connect}->{obj_cache};
|
||||
return $table_obj;
|
||||
}
|
||||
|
||||
sub new_relation {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the table objects and relation object for multi-table tasks.
|
||||
# Internal use. Call table instead.
|
||||
#
|
||||
my ($self, @tables) = @_;
|
||||
my $href = {};
|
||||
my $tables_ord = [];
|
||||
my $tables = {};
|
||||
|
||||
require GT::SQL::Relation;
|
||||
|
||||
my $cache_key = join "\0", "RELATION", @tables, $self->{connect}->{def_path};
|
||||
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
|
||||
$self->debug("Returning relation object for @tables from cache") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $cached;
|
||||
}
|
||||
|
||||
# Build our hash of prefixed table name to table object.
|
||||
foreach my $table (@tables) {
|
||||
$self->debug("CREATING GT::SQL::Table OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
my $tmp = $self->new_table($table);
|
||||
my $name = $tmp->name;
|
||||
push @$tables_ord, $name;
|
||||
$tables->{$name} = $tmp;
|
||||
}
|
||||
|
||||
# Get our driver, class name and key to look up subclasses (without prefixes).
|
||||
my $class = 'GT::SQL::Relation';
|
||||
my $prefix = $self->{connect}->{PREFIX};
|
||||
my $subclass_key = join "\0", map { s/^$prefix//; $_ } sort keys %{$tables};
|
||||
|
||||
# Look for any subclass to use, and load any error messages.
|
||||
no strict 'refs';
|
||||
|
||||
foreach my $table (values %{$tables}) {
|
||||
my $subclass = $table->subclass;
|
||||
if ((!exists $self->{subclass} or $self->{subclass}) and exists $subclass->{relation}->{$prefix . $subclass_key}) {
|
||||
$class = $subclass->{relation}->{$prefix . $subclass_key};
|
||||
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : next;
|
||||
foreach (keys %$errors) {
|
||||
$ERRORS->{$_} = $errors->{$_};
|
||||
}
|
||||
}
|
||||
}
|
||||
use strict 'refs';
|
||||
|
||||
# Load our relation object.
|
||||
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
$self->_load_module($class) or return;
|
||||
|
||||
my $rel = $class->new(
|
||||
tables => $tables,
|
||||
debug => $self->{_debug},
|
||||
connect => $self->{connect},
|
||||
_err_pkg => 'GT::SQL::Relation',
|
||||
tables_ord => $tables_ord
|
||||
);
|
||||
$GT::SQL::OBJ_CACHE{$cache_key} = $rel if ($self->{connect}->{obj_cache});
|
||||
|
||||
return $rel;
|
||||
}
|
||||
|
||||
# ============================================================================ #
|
||||
# CREATOR ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
$COMPILE{creator} = __LINE__ . <<'END_OF_SUB';
|
||||
sub creator {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a creator object. Takes a table name as argument.
|
||||
# my $creator = $db->creator('Links')
|
||||
#
|
||||
my $self = shift;
|
||||
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->creator(\'tablename\')');
|
||||
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'creator()');
|
||||
my $name = $self->{connect}->{PREFIX} . $table_name;
|
||||
|
||||
# Create either an empty schema or use an old one.
|
||||
$self->debug("Creating new GT::SQL::Table object '$table_name' to be used in Creator.") if $self->{_debug} and $self->{_debug} > 2;
|
||||
my $table = GT::SQL::Table->new(
|
||||
name => $table_name,
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Creator'
|
||||
);
|
||||
|
||||
# Return a creator object.
|
||||
require GT::SQL::Creator;
|
||||
$self->debug("CREATING GT::SQL::Creator OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
return GT::SQL::Creator->new(
|
||||
table => $table,
|
||||
debug => $self->{_debug},
|
||||
connect => $self->{connect}
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a driver object, and connects.
|
||||
#
|
||||
my $self = shift;
|
||||
return 1 if $self->{driver};
|
||||
$self->{connect} or return $self->fatal('NOCONNECT');
|
||||
|
||||
my $driver = uc $self->{connect}->{driver} || 'MYSQL';
|
||||
$self->{driver} = GT::SQL::Driver->load_driver(
|
||||
$driver,
|
||||
schema => $self->{tables} || $self->{schema},
|
||||
name => scalar $self->name,
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => $self->{_err_pkg}
|
||||
) or return $self->fatal(CANTLOAD => $driver, $GT::SQL::error);
|
||||
|
||||
unless ($self->{driver}->connect) {
|
||||
delete $self->{driver};
|
||||
return;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub count {
|
||||
# -------------------------------------------------------------------
|
||||
# $obj->count;
|
||||
# ------------
|
||||
# Returns the number of tuples handled
|
||||
# by this relation.
|
||||
#
|
||||
# $obj->count($condition);
|
||||
# -------------------------
|
||||
# Returns the number of tuples that matches
|
||||
# that $condition.
|
||||
#
|
||||
my $self = shift;
|
||||
my @cond;
|
||||
if (!ref $_[0] and @_ % 2 == 0 and defined $_[0]) {
|
||||
push @cond, {@_};
|
||||
}
|
||||
else {
|
||||
for (@_) {
|
||||
return $self->fatal(BADARGS => 'Arguments to count() must either be a hash, or one or more hash refs and/or GT::SQL::Condition objects')
|
||||
unless ref eq 'GT::SQL::Condition' or ref eq 'HASH';
|
||||
push @cond, $_;
|
||||
}
|
||||
}
|
||||
my $sel_opts = $self->{sel_opts};
|
||||
$self->{sel_opts} = [];
|
||||
my $sth = $self->select('COUNT(*)' => @cond ? GT::SQL::Condition->new(@cond) : ()) or return;
|
||||
$self->{sel_opts} = $sel_opts;
|
||||
return int $sth->fetchrow;
|
||||
}
|
||||
|
||||
$COMPILE{total} = __LINE__ . <<'END_OF_SUB';
|
||||
sub total {
|
||||
# -------------------------------------------------------------------
|
||||
# total()
|
||||
# IN : none
|
||||
# OUT: total number of records in table
|
||||
#
|
||||
shift->count
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{quote} = __LINE__ . <<'END_OF_SUB';
|
||||
sub quote {
|
||||
# -------------------------------------------------------------------
|
||||
# $obj->quote($value);
|
||||
# ---------------------
|
||||
# Returns the quoted representation of $value.
|
||||
#
|
||||
return GT::SQL::Driver::quote(pop)
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{hits} = __LINE__ . <<'END_OF_SUB';
|
||||
sub hits {
|
||||
# -----------------------------------------------------------
|
||||
# hits()
|
||||
# IN : none
|
||||
# OUT: number of results in last search. (calls count(*) on
|
||||
# demand from hits() or toolbar())
|
||||
#
|
||||
my $self = shift;
|
||||
if (! defined $self->{last_hits}) {
|
||||
$self->{last_hits} = (defined $self->{last_where} ? $self->count($self->{last_where}) : $self->count) || 0;
|
||||
}
|
||||
return $self->{last_hits};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_cgi_to_hash} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _cgi_to_hash {
|
||||
# -------------------------------------------------------------------
|
||||
# Internal Use
|
||||
# $self->_cgi_to_hash($in);
|
||||
# --------------------------
|
||||
# Creates a hash ref from a cgi object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
defined $cgi and ref $cgi =~ /CGI/ or return $self->fatal(BADARGS => "'$cgi' is not a CGI object");
|
||||
|
||||
my @keys = $cgi->param;
|
||||
my $result = {};
|
||||
for my $key (@keys) {
|
||||
my @values = $cgi->param($key);
|
||||
$result->{$key} = @values == 1 ? $values[0] : \@values;
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_get_search_opts} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _get_search_opts {
|
||||
# -------------------------------------------------------------------
|
||||
# Internal Use
|
||||
# _get_search_opts($hash_ref);
|
||||
# ----------------------------
|
||||
# Gets the search options based on the hash ref
|
||||
# passed in.
|
||||
#
|
||||
# sb => field_list # Return results sorted by field list.
|
||||
# so => [ASC|DESC] # Sort order of results.
|
||||
# mh => n # Return n results maximum, default to 25.
|
||||
# nh => n # Return the n'th set of results, default to 1.
|
||||
# rs => [col, col2] # A list of columns you want returned
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt_r = shift;
|
||||
my $ret = {};
|
||||
$ret->{nh} = (defined $opt_r->{nh} and $opt_r->{nh} =~ /^(\d+)$/) ? $1 : 1;
|
||||
$ret->{mh} = (defined $opt_r->{mh} and $opt_r->{mh} =~ /^(-?\d+)$/) ? $1 : 25;
|
||||
$ret->{so} = (defined $opt_r->{so} and $opt_r->{so} =~ /^(ASC|DESC)$/i) ? $1 : '';
|
||||
$ret->{sb} = (defined $opt_r->{sb} and $opt_r->{sb} =~ /^([\w\s,.]+)$/) ? $1 : '';
|
||||
|
||||
# You can pass in 'Col ASC, Col2 DESC' in {sb} so we need to remove sort order then.
|
||||
if ((lc $ret->{sb}) =~ /\s(?:asc|desc)/) {
|
||||
$ret->{so} = '';
|
||||
}
|
||||
if (defined $ret->{rs} and ref $ret->{rs} eq 'ARRAY') {
|
||||
my @valid;
|
||||
foreach my $col (@{$ret->{rs}}) {
|
||||
$col =~ /^([\w\s,]+)$/ and push @valid, $1;
|
||||
}
|
||||
$ret->{rs} = \@valid;
|
||||
}
|
||||
else {
|
||||
$ret->{rs} = (defined $opt_r->{rs} and $opt_r->{rs} =~ /^([\w\s,]+)$/) ? $1 : '';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Transitional support. build_query_cond _was_ a private method
|
||||
$COMPILE{_build_query_cond} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _build_query_cond {
|
||||
my $self = shift;
|
||||
warn "obj->_build_query_cond() is deprecated; use obj->build_query_cond()" if $self->{_debug};
|
||||
$self->build_query_cond(@_)
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{build_query_cond} = __LINE__ . <<'END_OF_SUB';
|
||||
sub build_query_cond {
|
||||
# -------------------------------------------------------------------
|
||||
# Builds a condition object based on form input.
|
||||
# field_name => value # Find all rows with field_name = value
|
||||
# field_name => ">=?value" # Find all rows with field_name > or >= value.
|
||||
# field_name => "<=?value" # Find all rows with field_name < or <= value.
|
||||
# field_name => "!value" # Find all rows with field_name != value.
|
||||
# field_name-opt => >=?|<=?|=|<>|LIKE|STARTS|ENDS
|
||||
# # Find all rows with field_name (whichever) value.
|
||||
# field_name-gt => value # Find all rows with field_name > value.
|
||||
# field_name-lt => value # Find all rows with field_name < value.
|
||||
# field_name-ge => value # Find all rows with field_name >= value.
|
||||
# field_name-le => value # Find all rows with field_name <= value.
|
||||
# field_name-ne => value # Find all rows with field_name != value.
|
||||
# keyword => value # Find all rows where any field_name = value
|
||||
# query => value # Find all rows using GT::SQL::Search module
|
||||
# ww => 1 # 1 => use = comparision, 0/unspecified => use LIKE '%value%' comparision
|
||||
# ma => 1 # 1 => OR match 0/unspecified => AND match
|
||||
#
|
||||
my ($self, $opts, $c) = @_;
|
||||
|
||||
my $cond = new GT::SQL::Condition;
|
||||
my ($cmp, $l);
|
||||
($cmp, $l) = $opts->{ww} ? ('=', '') : ('LIKE', '%');
|
||||
$cond->boolean($opts->{ma} ? 'OR' : 'AND');
|
||||
my $ins = 0;
|
||||
|
||||
# First find the fields and find what we
|
||||
# want to do with them.
|
||||
if (defined $opts->{query} and $opts->{query} =~ /\S/) {
|
||||
require GT::SQL::Search;
|
||||
my $search = GT::SQL::Search->load_search({
|
||||
%{$opts},
|
||||
db => $self->{driver},
|
||||
table => $self,
|
||||
debug => $self->{debug},
|
||||
_debug => $self->{_debug}
|
||||
});
|
||||
my $sth = $search->query();
|
||||
$self->{last_hits} = $search->rows();
|
||||
$self->{rejected_keywords} = $search->{rejected_keywords};
|
||||
return $sth;
|
||||
}
|
||||
elsif (defined $opts->{keyword} and ($opts->{keyword} ne "") and ($opts->{keyword} ne '*')) {
|
||||
my $val = $opts->{keyword};
|
||||
my $is_dig = $val =~ /^[+-]*\d+\.?\d*$/;
|
||||
|
||||
foreach my $field (keys %$c) {
|
||||
next unless (index($c->{$field}->{type}, 'DATE') == -1); # No DATE fields.
|
||||
next unless (index($c->{$field}->{type}, 'TIME') == -1); # No TIME fields.
|
||||
next unless (index($c->{$field}->{type}, 'ENUM') == -1); # No ENUM fields.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'INT') != -1)); # No ints if not an int.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'DECIMAL') != -1)); # No ints if not an int.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'FLOAT') != -1)); # No ints if not an int.
|
||||
|
||||
$cond->add($field, $cmp, "$l$opts->{keyword}$l");
|
||||
$ins = 1;
|
||||
}
|
||||
$cond->bool('OR');
|
||||
}
|
||||
else {
|
||||
|
||||
# Go through each column and build condition.
|
||||
foreach my $field (keys %$c) {
|
||||
my $comp = $cmp;
|
||||
my $s = $l;
|
||||
my $e = $l;
|
||||
my @ins;
|
||||
|
||||
if ($opts->{"$field-opt"}) {
|
||||
$comp = uc $opts->{"$field-opt"};
|
||||
|
||||
$s = $e = '';
|
||||
if ( $comp eq 'LIKE' ) {
|
||||
$e = $s = '%';
|
||||
}
|
||||
elsif ( $comp eq 'STARTS' ) {
|
||||
$comp = 'LIKE';
|
||||
$e = '%';
|
||||
}
|
||||
elsif ( $comp eq 'ENDS' ) {
|
||||
$comp = 'LIKE';
|
||||
$s = '%';
|
||||
}
|
||||
|
||||
}
|
||||
else {
|
||||
if ($c->{$field}->{type} =~ /ENUM/i) {
|
||||
$comp = '=';
|
||||
$e = $s = '';
|
||||
}
|
||||
}
|
||||
|
||||
# Comp can only be: =, <, >, <=, >=, <>, LIKE, STARTS, ENDS
|
||||
$comp = '=' unless $comp =~ /^(=|<=?|>=?|<>|LIKE)$/i;
|
||||
|
||||
if (exists $opts->{"$field-gt"} and ($opts->{"$field-gt"} ne "")) {
|
||||
push @ins, [$field, '>', $opts->{$field . "-gt"}];
|
||||
}
|
||||
if (exists $opts->{"$field-lt"} and ($opts->{"$field-lt"} ne "")) {
|
||||
push @ins, [$field, '<', $opts->{$field . "-lt"}];
|
||||
}
|
||||
if (exists $opts->{"$field-ge"} and ($opts->{"$field-ge"} ne "")) {
|
||||
push @ins, [$field, '>=', $opts->{$field . "-ge"}];
|
||||
}
|
||||
if (exists $opts->{"$field-le"} and ($opts->{"$field-le"} ne "")) {
|
||||
push @ins, [$field, '<=', $opts->{$field . "-le"}];
|
||||
}
|
||||
if (exists $opts->{"$field-ne"} and ($opts->{"$field-ne"} ne "")) {
|
||||
push @ins, [$field, '!=', $opts->{$field . "-ne"}];
|
||||
}
|
||||
|
||||
if (exists $opts->{$field} and ($opts->{$field} ne "")) {
|
||||
if (ref($opts->{$field}) eq 'ARRAY' ) {
|
||||
my $add = [];
|
||||
for ( @{$opts->{$field}} ) {
|
||||
next if !defined( $_ ) or !length( $_ ) or !/\S/;
|
||||
push @$add, $_;
|
||||
}
|
||||
if ( @$add ) {
|
||||
push @ins, [$field, 'IN', $add];
|
||||
}
|
||||
}
|
||||
elsif ($opts->{$field} =~ /^(>=?|<=?|!)(.*)/) {
|
||||
push @ins, [$field, ($1 eq '!') ? '<>' : $1, $2];
|
||||
}
|
||||
elsif ($opts->{$field} eq '+') {
|
||||
push @ins, [$field, "<>", ''];
|
||||
}
|
||||
elsif ($opts->{$field} eq '-') {
|
||||
push @ins, [$field, "=", ''];
|
||||
}
|
||||
elsif ($opts->{$field} eq '*') {
|
||||
if ($opts->{"$field-opt"} and ($opts->{"$field-opt"} eq '<>')) {
|
||||
push @ins, [$field, '=', ''];
|
||||
}
|
||||
else {
|
||||
next;
|
||||
}
|
||||
}
|
||||
else {
|
||||
substr($opts->{$field}, 0, 1) = "" if substr($opts->{$field}, 0, 1) eq '\\';
|
||||
push @ins, [$field, $comp, "$s$opts->{$field}$e"];
|
||||
}
|
||||
}
|
||||
|
||||
if (@ins) {
|
||||
for (@ins) {
|
||||
$cond->add($_);
|
||||
}
|
||||
$ins = 1;
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
return $ins ? $cond : '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _load_module {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a subclassed module.
|
||||
#
|
||||
my ($self, $class) = @_;
|
||||
|
||||
no strict 'refs';
|
||||
return 1 if (UNIVERSAL::can($class, 'new'));
|
||||
|
||||
(my $pkg = $class) =~ s,::,/,g;
|
||||
my $ok = 0;
|
||||
my @err = ();
|
||||
until ($ok) {
|
||||
local ($@, $SIG{__DIE__});
|
||||
eval { require "$pkg.pm" };
|
||||
if ($@) {
|
||||
push @err, $@;
|
||||
# In case the module had compile errors, %class:: will be defined, but not complete.
|
||||
undef %{$class . '::'} if %{$class . '::'};
|
||||
}
|
||||
else {
|
||||
$ok = 1;
|
||||
last;
|
||||
}
|
||||
my $pos = rindex($pkg, '/');
|
||||
last if $pos == -1;
|
||||
substr($pkg, $pos) = "";
|
||||
}
|
||||
unless ($ok and UNIVERSAL::can($class, 'new')) {
|
||||
return $self->fatal(BADSUBCLASS => $class, join ", ", @err);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user