608 lines
21 KiB
Perl
608 lines
21 KiB
Perl
# ==================================================================
|
|
# 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;
|