950 lines
29 KiB
Perl
950 lines
29 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Base
|
|
# Author : Alex Krohn
|
|
# CVS Info :
|
|
# $Id: Base.pm,v 1.132 2005/06/22 19:59:25 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Base module that handles common functions like initilization,
|
|
# debugging, etc. Should not be used except as a base class.
|
|
#
|
|
|
|
package GT::Base;
|
|
# ===============================================================
|
|
require 5.004; # We need perl 5.004 for a lot of the OO features.
|
|
|
|
use strict qw/vars subs/; # No refs as we do some funky stuff.
|
|
use vars qw/$AUTOLOAD $DEBUG $VERSION $ATTRIB_CACHE %ERRORS @EXPORT_OK %EXPORT_TAGS @ISA/;
|
|
use GT::AutoLoader(NEXT => 'GT::Base::_AUTOLOAD');
|
|
use Exporter();
|
|
|
|
# We need to inherit from Exporter for ->require_version support
|
|
@ISA = qw/Exporter/;
|
|
|
|
BEGIN {
|
|
if ($ENV{MOD_PERL}) {
|
|
eval { require mod_perl2 } or eval { require mod_perl };
|
|
}
|
|
require CGI::SpeedyCGI if $CGI::SpeedyCGI::i_am_speedy or $CGI::SpeedyCGI::_i_am_speedy;
|
|
}
|
|
use constants
|
|
MOD_PERL => $ENV{MOD_PERL} ? $mod_perl2::VERSION || $mod_perl::VERSION : 0,
|
|
SPEEDY => $CGI::SpeedyCGI::_i_am_speedy || $CGI::SpeedyCGI::i_am_speedy ? $CGI::SpeedyCGI::VERSION : 0;
|
|
use constants
|
|
PERSIST => MOD_PERL || SPEEDY;
|
|
|
|
$DEBUG = 0;
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.132 $ =~ /(\d+)\.(\d+)/;
|
|
$ATTRIB_CACHE = {};
|
|
%ERRORS = (
|
|
MKDIR => "Could not make directory '%s': %s",
|
|
OPENDIR => "Could not open directory '%s': %s",
|
|
RMDIR => "Could not remove directory '%s': %s",
|
|
CHMOD => "Could not chmod '%s': %s",
|
|
UNLINK => "Could not unlink '%s': %s",
|
|
READOPEN => "Could not open '%s' for reading: %s",
|
|
WRITEOPEN => "Could not open '%s' for writing: %s",
|
|
OPEN => "Could not open '%s': %s",
|
|
BADARGS => "Wrong argument passed to this subroutine. %s"
|
|
);
|
|
@EXPORT_OK = qw/MOD_PERL SPEEDY PERSIST $MOD_PERL $SPEEDY $PERSIST/;
|
|
%EXPORT_TAGS = (
|
|
all => \@EXPORT_OK,
|
|
persist => [qw/MOD_PERL SPEEDY PERSIST/]
|
|
);
|
|
|
|
# These three are for backwards-compatibility with what GT::Base used to
|
|
# export; new code should import and use the constants of the same name.
|
|
use vars qw/$MOD_PERL $SPEEDY $PERSIST/;
|
|
$MOD_PERL = MOD_PERL;
|
|
$SPEEDY = SPEEDY;
|
|
$PERSIST = PERSIST;
|
|
|
|
sub new {
|
|
# -------------------------------------------------------
|
|
# Create a base object and use set or init to initilize anything.
|
|
#
|
|
my $this = shift;
|
|
my $class = ref $this || $this;
|
|
|
|
# Create self with our debug value.
|
|
my $self = { _debug => defined ${"$class\:\:DEBUG"} ? ${"$class\:\:DEBUG"} : $DEBUG };
|
|
bless $self, $class;
|
|
$self->debug("Created new $class object.") if $self->{_debug} > 2;
|
|
|
|
# Set initial attributes, and then run init function or call set.
|
|
$self->reset;
|
|
if ($self->can('init')) {
|
|
$self->init(@_);
|
|
}
|
|
else {
|
|
$self->set(@_) if (@_);
|
|
}
|
|
|
|
if (index($self, 'HASH') != -1) {
|
|
$self->{_debug} = $self->{debug} if $self->{debug};
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub DESTROY {
|
|
# -------------------------------------------------------
|
|
# Object is nuked.
|
|
#
|
|
(index($_[0], 'HASH') > -1) or return;
|
|
if ($_[0]->{_debug} and $_[0]->{_debug} > 2) {
|
|
my ($package, $filename, $line) = caller;
|
|
$_[0]->debug("Destroyed $_[0] in package $package at $filename line $line.");
|
|
}
|
|
}
|
|
|
|
sub _AUTOLOAD {
|
|
# -------------------------------------------------------
|
|
# We use autoload to provide an accessor/setter for all
|
|
# attributes.
|
|
#
|
|
my ($self, $param) = @_;
|
|
my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/;
|
|
|
|
# If this is a known attribute, return/set it and save the function
|
|
# to speed up future calls.
|
|
my $autoload_attrib = 0;
|
|
if (ref $self and index($self, 'HASH') != -1 and exists $self->{$attrib} and not exists $COMPILE{$attrib}) {
|
|
$autoload_attrib = 1;
|
|
}
|
|
else {
|
|
# Class method possibly.
|
|
unless (ref $self) {
|
|
my $attribs = $ATTRIB_CACHE->{$self} || _get_attribs($self);
|
|
if (exists $attribs->{$attrib}) {
|
|
$autoload_attrib = 1;
|
|
}
|
|
}
|
|
}
|
|
# This is an accessor, create a function for it.
|
|
if ($autoload_attrib) {
|
|
*{$AUTOLOAD} = sub {
|
|
unless (ref $_[0]) { # Class Method
|
|
my $attribs = $ATTRIB_CACHE->{$_[0]} || _get_attribs($_[0]);
|
|
if (@_ > 1) {
|
|
$_[0]->debug("Setting base attribute '$attrib' => '$_[1]'.") if defined ${$_[0] . '::DEBUG'} and ${$_[0] . '::DEBUG'} > 2;
|
|
$ATTRIB_CACHE->{$_[0]}->{$attrib} = $_[1];
|
|
}
|
|
return $ATTRIB_CACHE->{$_[0]}->{$attrib};
|
|
}
|
|
if (@_ > 1) { # Instance Method
|
|
$_[0]->debug("Setting '$attrib' => '$_[1]'.") if $_[0]->{_debug} and $_[0]->{_debug} > 2;
|
|
$_[0]->{$attrib} = $_[1];
|
|
}
|
|
return $_[0]->{$attrib};
|
|
};
|
|
goto &$AUTOLOAD;
|
|
}
|
|
|
|
# Otherwise we have an error, let's help the user out and try to
|
|
# figure out what they were doing.
|
|
_generate_fatal($self, $attrib, $param);
|
|
}
|
|
|
|
sub set {
|
|
# -------------------------------------------------------
|
|
# Set one or more attributes.
|
|
#
|
|
return unless (@_);
|
|
if ( !ref $_[0]) { class_set(@_); }
|
|
else {
|
|
my $self = shift;
|
|
my $p = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', "Argument to set must be either hash, hash ref, array, array ref or CGI object.");
|
|
my $attribs = $ATTRIB_CACHE->{ref $self} || _get_attribs(ref $self);
|
|
my $f = 0;
|
|
$self->{_debug} = $p->{debug} || 0 if exists $p->{debug};
|
|
foreach my $attrib (keys %$attribs) {
|
|
next unless exists $p->{$attrib};
|
|
$self->debug("Setting '$attrib' to '${$p}{$attrib}'.") if $self->{_debug} and $self->{_debug} > 2;
|
|
$self->{$attrib} = $p->{$attrib};
|
|
$f++;
|
|
}
|
|
return $f;
|
|
}
|
|
}
|
|
|
|
sub common_param {
|
|
# -------------------------------------------------------
|
|
# Expects to find $self, followed by one or more arguments of
|
|
# unknown types. Converts them to hash refs.
|
|
#
|
|
shift;
|
|
my $out = {};
|
|
return $out unless @_ and defined $_[0];
|
|
CASE: {
|
|
(ref $_[0] eq 'HASH') and do { $out = shift; last CASE };
|
|
(UNIVERSAL::can($_[0], 'get_hash')) and do { $out = $_[0]->get_hash; last CASE };
|
|
(UNIVERSAL::can($_[0], 'param')) and do { foreach ($_[0]->param) { my @vals = $_[0]->param($_); $out->{$_} = (@vals > 1) ? \@vals : $vals[0]; } last CASE };
|
|
(defined $_[0] and not @_ % 2) and do { $out = {@_}; last CASE };
|
|
return;
|
|
}
|
|
return $out;
|
|
}
|
|
|
|
sub reset {
|
|
# -------------------------------------------------------
|
|
# Resets all attribs in $self.
|
|
#
|
|
my $self = shift;
|
|
my $class = ref $self;
|
|
my $attrib = $ATTRIB_CACHE->{$class} || _get_attribs($class);
|
|
|
|
# Deep copy hash and array refs only.
|
|
while (my ($k, $v) = each %$attrib) {
|
|
unless (ref $v) {
|
|
$self->{$k} = $v;
|
|
}
|
|
elsif (ref $v eq 'HASH') {
|
|
$self->{$k} = {};
|
|
foreach my $k1 (keys %{$attrib->{$k}}) {
|
|
$self->{$k}->{$k1} = $attrib->{$k}->{$k1};
|
|
}
|
|
}
|
|
elsif (ref $v eq 'ARRAY') {
|
|
$self->{$k} = [];
|
|
foreach my $v1 (@{$attrib->{$k}}) {
|
|
push @{$self->{$k}}, $v1;
|
|
}
|
|
}
|
|
else {
|
|
$self->{$k} = $v;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub _get_attribs {
|
|
# -------------------------------------------------------
|
|
# Searches through ISA and returns this packages attributes.
|
|
#
|
|
my $class = shift;
|
|
my $attrib = defined ${"$class\:\:ATTRIBS"} ? ${"$class\:\:ATTRIBS"} : {};
|
|
my @pkg_isa = defined @{"$class\:\:ISA"} ? @{"$class\:\:ISA"} : ();
|
|
|
|
foreach my $pkg (@pkg_isa) {
|
|
next if $pkg eq 'Exporter'; # Don't mess with Exporter.
|
|
next if $pkg eq 'GT::Base';
|
|
my $fattrib = defined ${"${pkg}::ATTRIBS"} ? ${"${pkg}::ATTRIBS"} : next;
|
|
foreach (keys %{$fattrib}) {
|
|
$attrib->{$_} = $fattrib->{$_} unless exists $attrib->{$_};
|
|
}
|
|
}
|
|
$ATTRIB_CACHE->{$class} = $attrib;
|
|
return $attrib;
|
|
}
|
|
|
|
$COMPILE{debug} = __LINE__ . <<'END_OF_FUNC';
|
|
sub debug {
|
|
# -------------------------------------------------------
|
|
# Displays a debugging message.
|
|
#
|
|
my ($self, $msg) = @_;
|
|
my $pkg = ref $self || $self;
|
|
|
|
# Add line numbers if asked for.
|
|
if ($msg !~ /\r?\n$/) {
|
|
my ($package, $file, $line) = caller;
|
|
$msg .= " at $file line $line.\n";
|
|
}
|
|
# Remove windows linefeeds (breaks unix terminals).
|
|
$msg =~ s/\r//g unless ($^O eq 'MSWin32');
|
|
$msg =~ s/\n(?=[^ ])/\n\t/g;
|
|
print STDERR "$pkg ($$): $msg";
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{debug_level} = __LINE__ . <<'END_OF_FUNC';
|
|
sub debug_level {
|
|
# -------------------------------------------------------
|
|
# Set the debug level for either the class or object.
|
|
#
|
|
if (ref $_[0]) {
|
|
$_[0]->{_debug} = shift if @_ > 1;
|
|
return $_[0]->{_debug};
|
|
}
|
|
else {
|
|
my $pkg = shift;
|
|
if (@_) {
|
|
my $level = shift;
|
|
${"${pkg}::DEBUG"} = $level;
|
|
}
|
|
return ${"${pkg}::DEBUG"};
|
|
}
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{warn} = __LINE__ . <<'END_OF_FUNC';
|
|
sub warn { shift->error(shift, WARN => @_) }
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{fatal} = __LINE__ . <<'END_OF_FUNC';
|
|
sub fatal { shift->error(shift, FATAL => @_) }
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{error} = __LINE__ . <<'END_OF_FUNC';
|
|
sub error {
|
|
# -------------------------------------------------------
|
|
# Error handler.
|
|
#
|
|
my $self = shift;
|
|
my ($msg, $level, @args) = @_;
|
|
my $pkg = ref $self || $self;
|
|
$level = defined $level ? $level : 'FATAL';
|
|
my $is_hash = index($self, 'HASH') != -1;
|
|
|
|
# Load the ERROR messages.
|
|
$self->set_basic_errors;
|
|
|
|
# err_pkg stores the package just before the users program for displaying where the error was raised
|
|
# think simplified croak.
|
|
my $err_pkg = $pkg;
|
|
if ($is_hash) {
|
|
$err_pkg = defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg;
|
|
}
|
|
|
|
# initilize vars to silence -w warnings.
|
|
# msg_pkg stores which package error messages are stored, defaults to self, but doesn't have to be.
|
|
${$pkg . '::ERROR_MESSAGE'} ||= '';
|
|
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
|
my $debug = $is_hash ? $self->{_debug} : ${$pkg . "::DEBUG"};
|
|
|
|
# cls_err stores the actual error hash (error_code => error_string). Initilize to prevent -w
|
|
# warnings.
|
|
${$msg_pkg . '::ERRORS'} ||= {};
|
|
${$pkg . '::ERRORS'} ||= {};
|
|
my $cls_err = ${$msg_pkg . '::ERRORS'};
|
|
my $pkg_err = ${$pkg . '::ERRORS'} || $pkg;
|
|
my %messages = %$cls_err;
|
|
foreach (keys %$pkg_err) { $messages{$_} = $pkg_err->{$_}; }
|
|
|
|
# Return current error if not called with arguments.
|
|
if ($is_hash) {
|
|
$self->{_error} ||= [];
|
|
if (@_ == 0) {
|
|
my @err = @{$self->{_error}} ? @{$self->{_error}} : (${$msg_pkg . "::error"});
|
|
return wantarray ? @err : defined($err[0]) ? $err[0] : undef;
|
|
}
|
|
}
|
|
elsif (@_ == 0) {
|
|
return ${$msg_pkg . '::errcode'};
|
|
}
|
|
|
|
# Set a subroutine that will clear out the error class vars, and self vars under mod_perl.
|
|
$self->register_persistent_cleanup(sub { $self->_cleanup_obj($msg_pkg, $is_hash) });
|
|
|
|
# store the error code.
|
|
${$msg_pkg . '::errcode'} ||= '';
|
|
${$msg_pkg . '::errcode'} = $msg;
|
|
${$msg_pkg . '::errargs'} ||= '';
|
|
if ($is_hash) {
|
|
$self->{_errcode} = $msg;
|
|
$self->{_errargs} = @args ? [@args] : [];
|
|
}
|
|
|
|
# format the error message.
|
|
if (keys %messages) {
|
|
if (exists $messages{$msg}) {
|
|
$msg = $messages{$msg};
|
|
}
|
|
$msg = $msg->(@args) if ref $msg eq 'CODE'; # Pass the sprintf arguments to the code ref
|
|
$msg = @args ? sprintf($msg, map { defined $_ ? $_ : '[undefined]' } @args) : $msg;
|
|
|
|
$msg =~ s/\r\n?/\n/g unless $^O eq 'MSWin32';
|
|
$msg =~ s/\n(?=[^ ])/\n\t/g;
|
|
}
|
|
|
|
# set the formatted error to $msg_pkg::error.
|
|
push @{$self->{_error}}, $msg if ($is_hash);
|
|
|
|
# If we have a fatal error, then we either send it to error_handler if
|
|
# the user has a custom handler, or print our message and die.
|
|
|
|
# Initialize $error to silence -w warnings.
|
|
${$msg_pkg . '::error'} ||= '';
|
|
if (uc $level eq 'FATAL') {
|
|
${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? _format_err($err_pkg, \$msg) : _format_err($err_pkg, $msg);
|
|
|
|
die(_format_err($err_pkg, $msg)) if in_eval();
|
|
if (exists($SIG{__DIE__}) and $SIG{__DIE__}) {
|
|
die _format_err($err_pkg, $msg);
|
|
}
|
|
else {
|
|
print STDERR _format_err($err_pkg, $msg);
|
|
die "\n";
|
|
}
|
|
}
|
|
# Otherwise we set the error message, and print it if we are in debug mode.
|
|
elsif (uc $level eq 'WARN') {
|
|
${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? \$msg : $msg;
|
|
my $warning = _format_err($err_pkg, $msg);
|
|
$debug and (
|
|
$SIG{__WARN__}
|
|
? CORE::warn $warning
|
|
: print STDERR $warning
|
|
);
|
|
$debug and $debug > 1 and (
|
|
$SIG{__WARN__}
|
|
? CORE::warn stack_trace('GT::Base',1)
|
|
: print STDERR stack_trace('GT::Base',1)
|
|
);
|
|
}
|
|
return;
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{_cleanup_obj} = __LINE__ . <<'END_OF_FUNC';
|
|
sub _cleanup_obj {
|
|
# -------------------------------------------------------
|
|
# Cleans up the self object under a persitant env.
|
|
#
|
|
my ($self, $msg_pkg, $is_hash) = @_;
|
|
|
|
${$msg_pkg . '::errcode'} = undef;
|
|
${$msg_pkg . '::error'} = undef;
|
|
${$msg_pkg . '::errargs'} = undef;
|
|
if ($is_hash) {
|
|
defined $self and $self->{_errcode} = undef;
|
|
defined $self and $self->{_error} = undef;
|
|
defined $self and $self->{_errargs} = undef;
|
|
}
|
|
return 1;
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{errcode} = __LINE__ . <<'END_OF_FUNC';
|
|
sub errcode {
|
|
# -------------------------------------------------------
|
|
# Returns the last error code generated.
|
|
#
|
|
my $self = shift;
|
|
my $is_hash = index($self, 'HASH') != -1;
|
|
my $pkg = ref $self || $self;
|
|
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
|
if (ref $self and $is_hash) {
|
|
return $self->{_errcode};
|
|
}
|
|
else {
|
|
return ${$msg_pkg . '::errcode'};
|
|
}
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{errargs} = __LINE__ . <<'END_OF_FUNC';
|
|
sub errargs {
|
|
# -------------------------------------------------------
|
|
# Returns the arguments from the last error. In list
|
|
# context returns an array, in scalar context returns
|
|
# an array reference.
|
|
#
|
|
my $self = shift;
|
|
my $is_hash = index($self, 'HASH') != -1;
|
|
my $pkg = ref $self || $self;
|
|
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
|
my $ret = [];
|
|
if (ref $self and $is_hash) {
|
|
$self->{_errargs} ||= [];
|
|
$ret = $self->{_errargs};
|
|
}
|
|
else {
|
|
${$msg_pkg . '::errcode'} ||= [];
|
|
$ret = ${$msg_pkg . '::errargs'};
|
|
}
|
|
return wantarray ? @{$ret} : $ret;
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{clear_errors} = __LINE__ . <<'END_OF_SUB';
|
|
sub clear_errors {
|
|
# -------------------------------------------------------
|
|
# Clears the error stack
|
|
#
|
|
my $self = shift;
|
|
$self->{_error} = [];
|
|
$self->{_errargs} = [];
|
|
$self->{_errcode} = undef;
|
|
return 1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{set_basic_errors} = __LINE__ . <<'END_OF_FUNC';
|
|
sub set_basic_errors {
|
|
# -------------------------------------------------------
|
|
# Sets basic error messages commonly used.
|
|
#
|
|
my $self = shift;
|
|
my $class = ref $self || $self;
|
|
if (${$class . '::ERROR_MESSAGE'}) {
|
|
$class = ${$class . '::ERROR_MESSAGE'};
|
|
}
|
|
${$class . '::ERRORS'} ||= {};
|
|
my $err = ${$class . '::ERRORS'};
|
|
for my $key (keys %ERRORS) {
|
|
$err->{$key} = $ERRORS{$key} unless exists $err->{$key};
|
|
}
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{whatis} = __LINE__ . <<'END_OF_SUB';
|
|
sub whatis {
|
|
# -----------------------------------------------------------------------------
|
|
# Takes a package name and returns a list of all packages inherited from, in
|
|
# the order they would be checked by Perl, _including_ the package passed in.
|
|
# The argument may be an object or a string, and this method can be called as
|
|
# a function, class method, or instance method. When called as a method, the
|
|
# argument is optional - if omitted, the class name will be used.
|
|
# Duplicate classes are _not_ included.
|
|
#
|
|
shift if @_ > 1;
|
|
my $class = shift;
|
|
$class = ref $class if ref $class;
|
|
my @isa = $class;
|
|
my %found;
|
|
my $pstash;
|
|
for (my $c = 0; $c < @isa; $c++) {
|
|
my $is = $isa[$c];
|
|
my @parts = split /::/, $is;
|
|
my $pstash = $::{shift(@parts) . "::"};
|
|
while (defined $pstash and @parts) {
|
|
$pstash = $pstash->{shift(@parts) . "::"};
|
|
}
|
|
if (defined $pstash and $pstash->{ISA} and my @is = @{*{\$pstash->{ISA}}{ARRAY}}) {
|
|
splice @isa, $c + 1, 0,
|
|
grep $_ eq $class
|
|
? die "Recursive inheritance detected in package $class"
|
|
: !$found{$_}++,
|
|
@is;
|
|
}
|
|
}
|
|
@isa
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{in_eval} = __LINE__ . <<'END_OF_FUNC';
|
|
sub in_eval {
|
|
# -------------------------------------------------------
|
|
# Current perl has a variable for it, old perl, we need to look
|
|
# through the stack trace. Ugh.
|
|
#
|
|
my $ineval;
|
|
if ($] >= 5.005 and !MOD_PERL) { $ineval = defined($^S) ? $^S : (stack_trace('GT::Base',1) =~ /\(eval\)/) }
|
|
elsif (MOD_PERL) {
|
|
my $stack = stack_trace('GT::Base', 1);
|
|
$ineval = $stack =~ m{
|
|
\(eval\)
|
|
(?!
|
|
\s+called\ at\s+
|
|
(?:
|
|
/dev/null
|
|
|
|
|
-e
|
|
|
|
|
/\S*/(?:Apache2?|ModPerl)/(?:Registry(?:Cooker)?|PerlRun)\.pm
|
|
|
|
|
PerlHandler\ subroutine\ `(?:Apache2?|ModPerl)::Registry
|
|
)
|
|
)
|
|
}x;
|
|
}
|
|
else {
|
|
my $stack = stack_trace('GT::Base', 1);
|
|
$ineval = $stack =~ /\(eval\)/;
|
|
}
|
|
return $ineval;
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{register_persistent_cleanup} = __LINE__ . <<'END_OF_SUB';
|
|
sub register_persistent_cleanup {
|
|
# -----------------------------------------------------------------------------
|
|
# Takes a code reference and registers it for cleanup under mod_perl and
|
|
# SpeedyCGI. Has no effect when not under those environments.
|
|
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
|
ref(my $code = shift) eq 'CODE'
|
|
or __PACKAGE__->fatal(BADARGS => 'Usage: GT::Base->register_persistent_cleanup($coderef)');
|
|
|
|
if (MOD_PERL and MOD_PERL >= 1.999022) { # Final mod_perl 2 API
|
|
require Apache2::ServerUtil;
|
|
if (Apache2::ServerUtil::restart_count() != 1) {
|
|
require Apache2::RequestUtil;
|
|
require APR::Pool;
|
|
Apache2::RequestUtil->request->pool->cleanup_register($code);
|
|
}
|
|
}
|
|
elsif (MOD_PERL and MOD_PERL >= 1.99) { # mod_perl 2 API prior to 2.0.0-RC5
|
|
require Apache2;
|
|
require Apache::ServerUtil;
|
|
if (Apache::ServerUtil::restart_count() != 1) {
|
|
require APR::Pool;
|
|
Apache->request->pool->cleanup_register($code);
|
|
}
|
|
}
|
|
elsif (MOD_PERL and $Apache::Server::Starting != 1) {
|
|
require Apache;
|
|
Apache->request->register_cleanup($code);
|
|
}
|
|
elsif (SPEEDY) {
|
|
CGI::SpeedyCGI->new->register_cleanup($code);
|
|
}
|
|
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{class_set} = __LINE__ . <<'END_OF_FUNC';
|
|
sub class_set {
|
|
# -------------------------------------------------------
|
|
# Set the class init attributes.
|
|
#
|
|
my $pkg = shift;
|
|
my $attribs = $ATTRIB_CACHE->{$pkg} || _get_attribs($pkg);
|
|
|
|
if (ref $attribs ne 'HASH') { return; }
|
|
|
|
# Figure out what we were passed in.
|
|
my $out = GT::Base->common_param(@_) or return;
|
|
|
|
# Set the attribs.
|
|
foreach (keys %$out) {
|
|
exists $attribs->{$_} and ($attribs->{$_} = $out->{$_});
|
|
}
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{attrib} = __LINE__ . <<'END_OF_FUNC';
|
|
sub attrib {
|
|
# -------------------------------------------------------
|
|
# Returns a list of attributes.
|
|
#
|
|
my $class = ref $_[0] || $_[0];
|
|
my $attribs = $ATTRIB_CACHE->{$class} || _get_attribs($class);
|
|
return wantarray ? %$attribs : $attribs;
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{stack_trace} = __LINE__ . <<'END_OF_FUNC';
|
|
sub stack_trace {
|
|
# -------------------------------------------------------
|
|
# If called with arguments, returns stack trace, otherwise
|
|
# prints to stdout/stderr depending on whether in cgi or not.
|
|
#
|
|
my $pkg = shift || 'Unknown';
|
|
my $raw = shift || 0;
|
|
my $rollback = shift || 3;
|
|
my ($ls, $spc, $fh);
|
|
if ($raw) {
|
|
if (defined $ENV{REQUEST_METHOD}) {
|
|
$ls = "\n";
|
|
$spc = ' ';
|
|
}
|
|
else {
|
|
$ls = "\n";
|
|
$spc = ' ';
|
|
}
|
|
}
|
|
elsif (defined $ENV{REQUEST_METHOD}) {
|
|
print STDOUT "Content-type: text/html\n\n";
|
|
$ls = '<br>';
|
|
$spc = ' ';
|
|
$fh = \*STDOUT;
|
|
}
|
|
else {
|
|
$ls = "\n";
|
|
$spc = ' ';
|
|
$fh = \*STDERR;
|
|
}
|
|
my $out = $raw ? '' : "${ls}STACK TRACE$ls======================================$ls";
|
|
{
|
|
package DB;
|
|
my $i = $rollback;
|
|
local $@;
|
|
while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) {
|
|
my @args;
|
|
for (@DB::args) {
|
|
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
|
|
my $print = $@ ? \$_ : $_;
|
|
push @args, defined $print ? $print : '[undef]';
|
|
}
|
|
if (@args) {
|
|
my $args = join ", ", @args;
|
|
$args =~ s/\n\s*\n/\n/g;
|
|
$args =~ s/\n/\n$spc$spc$spc$spc/g;
|
|
$out .= qq!$pkg ($$): $sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!;
|
|
}
|
|
else {
|
|
$out .= qq!$pkg ($$): $sub called at $file line $line with no arguments.$ls!;
|
|
}
|
|
}
|
|
}
|
|
$raw ? return $out : print $fh $out;
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{_format_err} = __LINE__ . <<'END_OF_FUNC';
|
|
sub _format_err {
|
|
# -------------------------------------------------------
|
|
# Formats an error message for output.
|
|
#
|
|
my ($pkg, $msg) = @_;
|
|
my ($file, $line) = get_file_line($pkg);
|
|
return "$pkg ($$): $msg at $file line $line.\n";
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{get_file_line} = __LINE__ . <<'END_OF_FUNC';
|
|
sub get_file_line {
|
|
# -------------------------------------------------------
|
|
# Find out what line error was generated in.
|
|
#
|
|
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
|
my $pkg = shift || scalar caller;
|
|
my %pkg;
|
|
for (whatis($pkg)) {
|
|
$pkg{$_}++;
|
|
}
|
|
my ($i, $last_pkg);
|
|
while (my $pack = caller($i++)) {
|
|
if ($pkg{$pack}) {
|
|
$last_pkg = $i;
|
|
}
|
|
elsif ($last_pkg) {
|
|
last; # We're one call back beyond the package being looked for
|
|
}
|
|
}
|
|
unless (defined $last_pkg) {
|
|
# You messed up by trying to pass in a package that was never called
|
|
GT::Base->fatal("get_file_line() called with an invalid package ($pkg)");
|
|
}
|
|
(undef, my ($file, $line)) = caller($last_pkg);
|
|
|
|
return ($file, $line);
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{_generate_fatal} = __LINE__ . <<'END_OF_FUNC';
|
|
sub _generate_fatal {
|
|
# -------------------------------------------------------------------
|
|
# Generates a fatal error caused by misuse of AUTOLOAD.
|
|
#
|
|
my ($self, $attrib, $param) = @_;
|
|
my $is_hash = index($self, 'HASH') != -1;
|
|
my $pkg = ref $self || $self;
|
|
|
|
my @poss;
|
|
if (UNIVERSAL::can($self, 'debug_level') and $self->debug_level) {
|
|
my @class = @{$pkg . '::ISA'} || ();
|
|
unshift @class, $pkg;
|
|
for (@class) {
|
|
my @subs = keys %{$_ . '::'};
|
|
my %compiled = %{$_ . '::COMPILE'};
|
|
for (keys %compiled) {
|
|
push @subs, $_ if defined $compiled{$_};
|
|
}
|
|
for my $routine (@subs) {
|
|
next if $attrib eq $routine;
|
|
next unless $self;
|
|
next unless defined $compiled{$_} or UNIVERSAL::can($self, $routine);
|
|
if (GT::Base->_sndex($attrib) eq GT::Base->_sndex($routine)) {
|
|
push @poss, $routine;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# Generate an error message, with possible alternatives and die.
|
|
my $err_pkg = $is_hash ? (defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg) : $pkg;
|
|
my ($call_pkg, $file, $line) = caller(1);
|
|
my $msg = @poss
|
|
? " Perhaps you meant to call " . join(", or " => @poss) . ".\n"
|
|
: '';
|
|
die "$err_pkg ($$): Unknown method '$attrib' called at $file line $line.\n$msg";
|
|
}
|
|
END_OF_FUNC
|
|
|
|
$COMPILE{_sndex} = __LINE__ . <<'END_OF_FUNC';
|
|
sub _sndex {
|
|
# -------------------------------------------------------
|
|
# Do a soundex lookup to suggest alternate methods the person
|
|
# might have wanted.
|
|
#
|
|
my $self = shift;
|
|
local $_ = shift;
|
|
my $search_sound = uc;
|
|
$search_sound =~ tr/A-Z//cd;
|
|
if ($search_sound eq '') { $search_sound = 0 }
|
|
else {
|
|
my $f = substr($search_sound, 0, 1);
|
|
$search_sound =~ tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/;
|
|
my $fc = substr($search_sound, 0, 1);
|
|
$search_sound =~ s/^$fc+//;
|
|
$search_sound =~ tr///cs;
|
|
$search_sound =~ tr/0//d;
|
|
$search_sound = $f . $search_sound . '000';
|
|
$search_sound = substr($search_sound, 0, 4);
|
|
}
|
|
return $search_sound;
|
|
}
|
|
END_OF_FUNC
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::Base - Common base module to be inherited by all classes.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use GT::Base;
|
|
use vars qw/@ISA $ATTRIBS $ERRORS/
|
|
@ISA = qw/GT::Base/;
|
|
$ATTRIBS = {
|
|
accessor => default,
|
|
accessor2 => default,
|
|
};
|
|
$ERRORS = {
|
|
BADARGS => "Invalid argument: %s passed to subroutine: %s",
|
|
};
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::Base is a base class that is used to provide common error handling,
|
|
debugging, creators and accessor methods.
|
|
|
|
To use GT::Base, simply make your module inherit from GT::Base. That
|
|
will provide the following functionality:
|
|
|
|
=head2 Debugging
|
|
|
|
Two new methods are available for debugging:
|
|
|
|
$self->debug($msg, [DEBUG_LEVEL]);
|
|
|
|
This will send a $msg to STDERR if the current debug level is greater
|
|
then the debug level passed in (defaults to 1).
|
|
|
|
$self->debug_level(DEBUG_LEVEL);
|
|
Class->debug_level(DEBUG_LEVEL);
|
|
|
|
You can call debug_level() to set or get the debug level. It can
|
|
be set per object by calling it as an object method, or class wide
|
|
which will initilize all new objects with that debug level (only if
|
|
using the built in creator).
|
|
|
|
The debugging uses a package variable:
|
|
|
|
$Class::DEBUG = 0;
|
|
|
|
and assumes it exists.
|
|
|
|
=head2 Error Handling
|
|
|
|
Your object can now generate errors using the method:
|
|
|
|
$self->error(CODE, LEVEL, [args]);
|
|
|
|
CODE should be a key to a hash of error codes to user readable
|
|
error messages. This hash should be stored in $ERRORS which is
|
|
defined in your pacakge, or the package named in $ERROR_MESSAGE.
|
|
|
|
LEVEL should be either 'FATAL' or 'WARN'. If not specified it defaults
|
|
to FATAL. If it's a fatal error, the program will print the message
|
|
to STDERR and die.
|
|
|
|
args can be used to format the error message. For instance, you can
|
|
defined commonly used errors like:
|
|
|
|
CANTOPEN => "Unable to open file: '%s': %s"
|
|
|
|
in your $ERRORS hash. Then you can call error like:
|
|
|
|
open FILE, "somefile.txt"
|
|
or return $self->error(CANTOPEN => FATAL => "somefile.txt", "$!");
|
|
|
|
The error handler will format your message using sprintf(), so all
|
|
regular printf formatting strings are allowed.
|
|
|
|
Since errors are kept within an array, too many errors can pose a
|
|
memory problem. To clear the error stack simply call:
|
|
|
|
$self->clear_errors();
|
|
|
|
=head2 Error Trapping
|
|
|
|
You can specify at run time to trap errors.
|
|
|
|
$self->catch_errors(\&code_ref);
|
|
|
|
which sets a $SIG{__DIE__} handler. Any fatal errors that occur, will
|
|
run your function. The function will not be run if the fatal was thrown
|
|
inside of an eval though.
|
|
|
|
=head2 Stack Trace
|
|
|
|
You can print out a stack trace at any time by using:
|
|
|
|
$self->stack_trace(1);
|
|
Class->stack_trace(1);
|
|
|
|
If you pass in 1, the stack trace will be returned as a string, otherwise
|
|
it will be printed to STDOUT.
|
|
|
|
=head2 Accessor Methods
|
|
|
|
Using GT::Base automatically provides accessor methods for all your
|
|
attributes. By specifying:
|
|
|
|
$ATTRIBS = {
|
|
attrib => 'default',
|
|
...
|
|
};
|
|
|
|
in your package, you can now call:
|
|
|
|
my $val = $obj->attrib();
|
|
$obj->attrib($set_val);
|
|
|
|
to set and retrieve the attributes for that value.
|
|
|
|
Note: This uses AUTOLOAD, so if you implement AUTOLOAD in your package,
|
|
you must have it fall back to GT::Base::AUTOLOAD if it fails. This
|
|
can be done with:
|
|
|
|
AUTOLOAD {
|
|
...
|
|
goto >::Base::AUTOLOAD;
|
|
}
|
|
|
|
which will pass all arguments as well.
|
|
|
|
=head2 Parameter Parsing
|
|
|
|
GT::Base also provides a method to parse parameters. In your methods you
|
|
can do:
|
|
|
|
my $self = shift;
|
|
my $parm = $self->common_param(@_);
|
|
|
|
This will convert any of a hash reference, hash or CGI object into a hash
|
|
reference.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Base.pm,v 1.132 2005/06/22 19:59:25 jagerman Exp $
|
|
|
|
=cut
|