#
#
# Copyright (C) 2006-2010 Andrew Speer <andrew@webdyne.org>.
# All rights reserved.
#
# This file is part of WebDyne.
#
# WebDyne is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
#
package WebDyne::Base;
# Compiler Pragma
#
sub BEGIN { $^W=0 };
use strict qw(vars);
use vars qw($VERSION @EXPORT);
use warnings;
no warnings qw(uninitialized redefine once);
# External modules
#
use Data::Dumper;
use IO::File;
# Use Exporter
#
require Exporter;
# Exports
#
@EXPORT=qw(err errstr errclr errdump errsubst errstack errnofatal);
# Version information
#
$VERSION='1.015';
# Var to hold package wide hash, for data shared across package, and error stack
#
my (%Package, @Err);
# All done. Positive return
#
1;
#==================================================================================================
sub import {
# Get message
#
my ($message, @param)=@_;
# Get who is calling us
#
my $caller=(caller(0))[0] || return undef;
# fh we will write to
#
my $debug_fh;
# Environment var overrides all
#
if ($ENV{'WEBDYNE_DEBUG_FILE'}) {
# fn is whatever spec'd
#
my $fn=$ENV{'WEBDYNE_DEBUG_FILE'};
$debug_fh=IO::File->new($fn, O_CREAT|O_APPEND|O_WRONLY) || do {
warn("unable to open file '$fn', $!");
undef;
}
}
elsif ($ENV{'WEBDYNE_DEBUG'}) {
# fh is stderr
#
$debug_fh=\*STDERR;
}
elsif (ref(my $debug_hr=${"${caller}::DEBUG"}) eq 'HASH') {
# Debug is hash ref, extract filename etc and open
#
my ($fn, $mode, $package)=@{$debug_hr}{qw(filename mode package)};
$fn ||= $debug_hr->{'file'}; #Alias
if ($fn && ($package ? ($package eq $caller) : 1)) {
$mode ||= O_CREAT|O_APPEND|O_WRONLY;
$debug_fh=($Package{'debug_fh'}{$fn} ||= (
IO::File->new($fn,$mode) || do {
warn("unable to open file '$fn', $!");
undef;
}));
}
elsif (!$fn) {
warn(sprintf('no file name specified in DEBUG hash %s', Dumper($debug_hr)));
}
}
elsif (!ref(my $fn=${"${caller}::DEBUG"}) && ${"${caller}::DEBUG"}) {
# Just file name spec'd. Open
#
$debug_fh=(
$Package{'debug_fh'}{$fn} ||= (
IO::File->new($fn, O_CREAT|O_APPEND|O_WRONLY) || do {
warn("unable to open file '$fn', $!");
undef;
}));
}
# After all that did we get a file handle ? If so, import the debug handler
#
if ($debug_fh) {
# Yes, setup debug routine
#
$debug_fh->autoflush(1);
*{"${caller}::debug" }= sub {
local $|=1;
my $method=(caller(1))[3] || 'main';
(my $subroutine=$method)=~s/^.*:://;
if ($ENV{'WEBDYNE_DEBUG'} && ($ENV{'WEBDYNE_DEBUG'} ne '1')) {
my @debug_target=split(/[,;:]/, $ENV{'WEBDYNE_DEBUG'});
foreach my $debug_target(@debug_target) {
if (($caller eq $debug_target) || ($method=~/\Q$debug_target\E$/)) {
CORE::print $debug_fh "[$subroutine] ", sprintf(shift(), @_), $/;
}
}
}
else {
CORE::print $debug_fh "[$subroutine] ", $_[1] ? sprintf(shift(), @_) : $_[0], $/;
}
} unless UNIVERSAL::can($caller, 'debug');
*{"${caller}::Dumper"}=\&Data::Dumper::Dumper unless UNIVERSAL::can($caller, 'Dumper');
}
else {
# No, null our debug and Dumper routine
#
*{"${caller}::debug" }= sub {} unless UNIVERSAL::can($caller, 'debug');
#*{"${caller}::Dumper"}= sub {} unless UNIVERSAL::can($caller, 'Dumper');
};
# Setup file handle for error backtrace
#
if (my $fn=${"${caller}::ERROR"}) {
# Just file name spec'd. Log
#
$Package{'error_fn'}{$fn}++
}
# Done
#
goto &Exporter::import;
}
sub errnofatal {
#
#
@_ ? $Package{'nofatal'}=@_ : $Package{'nofatal'};
}
sub err {
# Get the message and any sprintf params
#
my ($message, @param)=@_;
# If no message supplied return last one seen
#
unless ($message) {
$message=@Err ? $Err[$#Err]->[0] && return undef : 'undefined error';
}
else {
$message=sprintf($message, @param) if @param;
}
# Init the caller var and array
#
my @caller;
my $caller=(caller(0))[0];
# Populate the caller array
#
for (my $i=0; my @info=(caller($i))[0..3]; $i++) {
# Push onto the caller array
#
push @caller, \@info;
}
# If this message is *not* the same as the last one we saw,
# we will log it
#
unless ($message eq (@Err && $Err[0]->[0])) {
# Add to stack
#
unshift @Err, [$message, @caller];
# If caller has a debug function enabled, call this with the warning
#
if (UNIVERSAL::can($caller, 'debug')) {
# Yes, they are using the debug module, so can we call it
#
&{"${caller}::debug"}($message);
}
# Dump to backtrace file if enabled
#
foreach my $fn (keys %{$Package{'error_fn'}}) {
unless (my $fh=IO::File->new($fn, O_CREAT|O_APPEND|O_WRONLY)) {
warn("unable to open file '$fn', $!");
}
else {
seek($fh,0,2); # Seek to EOF
my $errdump=&errdump();
CORE::print $fh $errdump, $/,$/;
$fh->close();
}
}
}
# Return undef
#
return $Package{'nofatal'} ? undef : die(&errdump);
}
sub errstr {
# Check that there are messages in the stack before trying to get
# the last one
#
if (my $count=@Err) {
# There are objects in the array, so it is safe to do a fetch
# on the last (-1) array slot
#
my $errstr=$Err[--$count]->[0];
# And return the errstr
#
return $errstr;
}
else {
# Nothing in the array stack, return undef
#
return undef;
}
}
sub errclr {
# Clear the warning stack
#
undef @Err;
# Replace errors if args
#
@_ && (return &err(@_));
# Return OK always
#
return 1;
}
sub errsubst {
# Replace the current error message with a new one, keeping callback
# stack
#
my ($message, @param)=@_;
# If no message supplied return last one seen
#
unless ($message) {
$message=@Err ? $Err[$#Err]->[0] && return undef : 'undefined error';
}
else {
$message=sprintf($message, @param);
}
# Chomp the message
#
chomp($message);
# Replace if present, define if not
#
@Err ? ($Err[$#Err]->[0] = $message) : goto &err;
# Return
#
return undef;
}
sub errdump {
# Use can send additional info to dump as key/value pairs in hash ref
# supplied as arg
#
my $info_hr=shift();
# Return a dump of error in a nice format, no params. Do this with
# format strings, so define the ones we will use
#
my @format=(
'+' . ('-' x 78) . "+\n",
"| @<<<<< | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< |\n",
"| | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~ |\n"
);
# Go through the message stack on error at a time in reverse order
#
foreach my $err_ar (reverse @Err) {
# Get message, clean up
#
my $message=ucfirst($err_ar->[0]);
$message=~s/\s+$//;
$message.='.' unless $message=~/[\.\!\?]$/;
my @message=split("\n", $message);
$message=shift @message if @message;
# Print out date, time, error message
#
formline $format[0];
formline $format[1], 'Date', scalar(localtime());
formline $format[0];
formline $format[1], 'Error', $message;
(formline $format[2], $message) if $message;
map {formline $format[2], $_} @message if @message;
formline $format[0];
# Flag so we know we have printed the caller field
#
my $caller_fg;
# Go through callback stack
#
for (my $i=1; defined($err_ar->[$i]); $i++) {
# Get method, line no and file
#
my $method=$err_ar->[$i+1][3] || $err_ar->[$i][0] || last;
my $lineno=$err_ar->[$i][2] || next;
my $filenm=$err_ar->[$i][1];
# Print them out, print out caller label unless we
# have already done so
#
formline $format[1],
$caller_fg ++ ? '' : 'Caller' , "$method, line $lineno";
}
# Include any user supplied info
#
while (my ($key, $value)=each %{$info_hr}) {
# Print separator, info
#
formline $format[0];
formline $format[1], $key, $value;
(formline $format[2], $value) if $value;
}
# Finish off formatting, print PID. Dont ask me why $$ has to be "$$",
# it does not show up any other way
#
formline $format[0];
formline $format[1], 'PID', "$$";
formline $format[0];
formline "\n";
}
# Empty the format accumulator and return it
#
my $return=$^A; undef $^A;
return $return;
}
sub errstack {
# Return or push the raw error stack
#
return @_ ? \(@Err=@{$_[1]}) : \@Err;
}