| Current File : //var/wcp4/million/public_html/file/private/lib/GT/Base.pm |
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Base
# Author : Alex Krohn
# $Id: Base.pm,v 1.108 2002/05/31 19:15:16 jagerman Exp $
#
# Copyright (c) 2000 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 $MOD_PERL $SPEEDY $PERSIST %ERRORS/;
use GT::AutoLoader(NEXT => 'GT::Base::_AUTOLOAD');
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.108 $ =~ /(\d+)\.(\d+)/;
$MOD_PERL = (exists $ENV{GATEWAY_INTERFACE} and ($ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl/)) ? 1 : 0;
$SPEEDY = ($CGI::SpeedyCGI::_i_am_speedy or $CGI::SpeedyCGI::i_am_speedy) ? 1 : 0;
$PERSIST = $MOD_PERL || $SPEEDY;
$ATTRIB_CACHE = {};
%ERRORS = (
MKDIR => "Could not make directory (%s). Reason: %s",
OPENDIR => "Could not open directory (%s). Reason: %s",
RMDIR => "Could not remove directory (%s). Reason: %s",
CHMOD => "Could not chmod (%s). Reason: %s",
UNLINK => "Could not unlink (%s). Reason: %s",
READOPEN => "Could not open (%s) for reading. Reason: %s",
WRITEOPEN => "Could not open (%s) for writting. Reason: %s",
OPEN => "Could not open (%s). Reason: %s",
BADARGS => "Wrong argument passed to this subroutine. Usage: %s"
);
sub import {
# -------------------------------------------------------
# Only exports $MOD_PERL, $SPEEDY, and $PERSIST.
#
my $pkg = shift;
my %symbol = map { $_ => 1 } @_;
my $callpkg = caller;
*{$callpkg . '::MOD_PERL'} = \$MOD_PERL if $symbol{'$MOD_PERL'} or $symbol{':all'};
*{$callpkg . '::SPEEDY'} = \$SPEEDY if $symbol{'$SPEEDY'} or $symbol{':all'};
*{$callpkg . '::PERSIST'} = \$PERSIST if $symbol{'$PERSIST'} or $symbol{':all'};
return;
}
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 ! exists $COMPILE{$attrib}) {
$autoload_attrib = 1;
}
else {
# Class method possibly.
if (! 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 {
if (! 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 (defined $_[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;
$attribs->{debug} = 0 unless exists $attribs->{debug};
foreach my $attrib (keys %$attribs) {
next unless (exists $p->{$attrib});
$self->debug ("Setting '$attrib' to '${$p}{$attrib}'.") if ($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) {
if (! 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]) {
@_ > 1 and ($_[0]->{_debug} = $_[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 advanced 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.
$MOD_PERL and $Apache::ServerStarting != 1 and Apache->request->register_cleanup( sub { $self->_cleanup_obj ($msg_pkg, $is_hash); } );
$SPEEDY and CGI::SpeedyCGI->register_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->() if ref $msg eq 'CODE';
$msg = @args ? sprintf ($msg, map { defined $_ ? $_ : '[undefined]' } @args) : $msg;
$msg =~ s/(?:\r?\n)|\r/\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.
# initlize 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 > 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{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 or $SPEEDY)) { $ineval = defined ($^S) ? $^S : (stack_trace('GT::Base',1) =~ /\(eval\)/); }
elsif ($MOD_PERL or $SPEEDY) {
my $stack = stack_trace('GT::Base', 1);
my $cnt = $stack =~ s|\(eval\)(?!\s+called at\s+/dev/null)||g;
$ineval = ($cnt > 1);
}
else {
my $stack = stack_trace('GT::Base', 1);
$ineval = $stack =~ /\(eval\)/;
}
return $ineval;
}
END_OF_FUNC
$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 $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__);
my $pkg = shift || scalar caller;
my ($pack, $file, $line, $i, @rest, $last_pkg);
while (($pack, $file, $line, @rest) = caller ($i++)) {
if ($pack eq $pkg) {
$last_pkg = $i;
}
}
($pack, $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;
my @class = @{$pkg . '::ISA'} || ();
unshift @class, $pkg;
foreach (@class) {
my %stach = %{$_ . '::'};
foreach my $routine (keys %stach) {
next if $attrib eq $routine;
next unless $self;
next unless (UNIVERSAL::can($self, $routine));
if (GT::Base->_sndex ($attrib) eq _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 = " Perhaps you ment to call " . join (", or " => @poss) . ".\n" if (@poss);
$msg = defined $msg ? $msg : '';
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. Reason: %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) 2002 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Base.pm,v 1.108 2002/05/31 19:15:16 jagerman Exp $
=cut