saint/discourse-legacysite-perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
main
discourse-legacysite-perl/site/glist/lib/GT/Base.pm

950 lines
29 KiB
Perl
Raw Permalink Normal View History

First pass at adding key files
2024-06-17 11:49:12 +00:00
# ==================================================================
# 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 = ' &nbsp; ';
}
else {
$ls = "\n";
$spc = ' ';
}
}
elsif (defined $ENV{REQUEST_METHOD}) {
print STDOUT "Content-type: text/html\n\n";
$ls = '<br>';
$spc = '&nbsp;';
$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 &GT::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
Reference in New Issue Copy Permalink