Revision c311f0f2
Von Moritz Bunkus vor fast 14 Jahren hinzugefügt
| modules/fallback/Exception/Lite.pm | ||
|---|---|---|
|
# Copyright (c) 2010 Elizabeth Grace Frank-Backman.
|
||
|
# All rights reserved.
|
||
|
# Liscenced under the "Artistic Liscence"
|
||
|
# (see http://dev.perl.org/licenses/artistic.html)
|
||
|
|
||
|
use 5.8.8;
|
||
|
use strict;
|
||
|
use warnings;
|
||
|
use overload;
|
||
|
|
||
|
package Exception::Lite;
|
||
|
our @ISA = qw(Exporter);
|
||
|
our @EXPORT_OK=qw(declareExceptionClass isException isChainable
|
||
|
onDie onWarn);
|
||
|
our %EXPORT_TAGS
|
||
|
=( common => [qw(declareExceptionClass isException isChainable)]
|
||
|
, all => [@EXPORT_OK]
|
||
|
);
|
||
|
my $CLASS='Exception::Lite';
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
our $STRINGIFY=3;
|
||
|
our $FILTER=1;
|
||
|
our $UNDEF='<undef>';
|
||
|
our $TAB=3;
|
||
|
our $LINE_LENGTH=120;
|
||
|
|
||
|
# provide command line control over amount and layout of debugging
|
||
|
# information, e.g. perl -mException::Lite=STRINGIFY=4
|
||
|
|
||
|
sub import {
|
||
|
Exception::Lite->export_to_level(1, grep {
|
||
|
if (/^(\w+)=(.*)$/) {
|
||
|
my $k = $1;
|
||
|
my $v = $2;
|
||
|
if ($k eq 'STRINGIFY') { $STRINGIFY=$v;
|
||
|
} elsif ($k eq 'FILTER') { $FILTER=$v;
|
||
|
} elsif ($k eq 'LINE_LENGTH') { $LINE_LENGTH=$v;
|
||
|
} elsif ($k eq 'TAB') { $TAB=$v;
|
||
|
}
|
||
|
0;
|
||
|
} else {
|
||
|
1;
|
||
|
}
|
||
|
} @_);
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
# Note to source code divers: DO NOT USE THIS. This is intended for
|
||
|
# internal use but must be declared with "our" because we need to
|
||
|
# localize it. This is an implementation detail and cannot be relied
|
||
|
# on for future releases.
|
||
|
|
||
|
our $STACK_OFFSET=0;
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
use Scalar::Util ();
|
||
|
use constant EVAL => '(eval)';
|
||
|
|
||
|
#==================================================================
|
||
|
# EXPORTABLE FUNCTIONS
|
||
|
#==================================================================
|
||
|
|
||
|
sub declareExceptionClass {
|
||
|
my ($sClass, $sSuperClass, $xFormatRule, $bCustomizeSubclass) = @_;
|
||
|
my $sPath = $sClass; $sPath =~ s/::/\//g; $sPath .= '.pm';
|
||
|
if ($INC{$sPath}) {
|
||
|
# we want to start with the caller's frame, not ours
|
||
|
local $STACK_OFFSET = $STACK_OFFSET + 1;
|
||
|
die 'Exception::Lite::Any'->new("declareExceptionClass failed: "
|
||
|
. "$sClass is already defined!");
|
||
|
return undef;
|
||
|
}
|
||
|
|
||
|
my $sRef=ref($sSuperClass);
|
||
|
if ($sRef) {
|
||
|
$bCustomizeSubclass = $xFormatRule;
|
||
|
$xFormatRule = $sSuperClass;
|
||
|
$sSuperClass=undef;
|
||
|
} else {
|
||
|
$sRef = ref($xFormatRule);
|
||
|
if (!$sRef && defined($xFormatRule)) {
|
||
|
$bCustomizeSubclass = $xFormatRule;
|
||
|
$xFormatRule = undef;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
# set up things dependent on whether or not the class has a
|
||
|
# format string or expects a message for each instance
|
||
|
|
||
|
my ($sLeadingParams, $sAddOrOmit, $sRethrowMsg, $sMakeMsg);
|
||
|
my $sReplaceMsg='';
|
||
|
|
||
|
if ($sRef) {
|
||
|
$sLeadingParams='my $e; $e=shift if ref($_[0]);';
|
||
|
$sAddOrOmit='added an unnecessary message or format';
|
||
|
$sRethrowMsg='';
|
||
|
|
||
|
#generate format rule
|
||
|
$xFormatRule=$xFormatRule->($sClass) if ($sRef eq 'CODE');
|
||
|
|
||
|
my $sFormat= 'q{' . $xFormatRule->[0] . '}';
|
||
|
if (scalar($xFormatRule) == 1) {
|
||
|
$sMakeMsg='my $msg='.$sFormat;
|
||
|
} else {
|
||
|
my $sSprintf = 'Exception::Lite::_sprintf(' . $sFormat
|
||
|
. ', map {defined($_)?$_:\''. $UNDEF .'\'} @$h{qw('
|
||
|
. join(' ', @$xFormatRule[1..$#$xFormatRule]) . ')});';
|
||
|
$sMakeMsg='my $msg='.$sSprintf;
|
||
|
$sReplaceMsg='$_[0]->[0]='.$sSprintf;
|
||
|
}
|
||
|
|
||
|
} else {
|
||
|
$sLeadingParams = 'my $e=shift; my $msg;'.
|
||
|
'if(ref($e)) { $msg=shift; $msg=$e->[0] if !defined($msg);}'.
|
||
|
'else { $msg=$e;$e=undef; }';
|
||
|
$sAddOrOmit='omitted a required message';
|
||
|
$sRethrowMsg='my $msg=shift; $_[0]->[0]=$msg if defined($msg);';
|
||
|
$sMakeMsg='';
|
||
|
}
|
||
|
|
||
|
# put this in an eval so that it doesn't cause parse errors at
|
||
|
# compile time in no-threads versions of Perl
|
||
|
|
||
|
my $sTid = eval q{defined(&threads::tid)?'threads->tid':'undef'};
|
||
|
|
||
|
my $sDeclare = "package $sClass;".
|
||
|
'sub new { my $cl=shift;'. $sLeadingParams .
|
||
|
'my $st=Exception::Lite::_cacheStackTrace($e);'.
|
||
|
'my $h= Exception::Lite::_shiftProperties($cl' .
|
||
|
',$st,"'.$sAddOrOmit.'",@_);' . $sMakeMsg .
|
||
|
'my $self=bless([$msg,$h,$st,$$,'.$sTid.',$e,[]],$cl);';
|
||
|
|
||
|
# the remainder depends on the type of subclassing
|
||
|
|
||
|
if ($bCustomizeSubclass) {
|
||
|
$sDeclare .= '$self->[7]={}; $self->_new(); return $self; }'
|
||
|
. 'sub _p_getSubclassData { $_[0]->[7]; }';
|
||
|
} else {
|
||
|
$sDeclare .= 'return $self;}'.
|
||
|
'sub replaceProperties {'.
|
||
|
'my $h={%{$_[0]->[1]},%{$_[1]}}; $_[0]->[1]=$h;'.$sReplaceMsg.
|
||
|
'}'.
|
||
|
'sub rethrow {' .
|
||
|
'my $self=shift;' . $sRethrowMsg .
|
||
|
'Exception::Lite::_rethrow($self,"'.$sAddOrOmit.'",@_)' .
|
||
|
'}';
|
||
|
|
||
|
unless (isExceptionClass($sSuperClass)) {
|
||
|
$sDeclare .=
|
||
|
'sub _getInterface { \'Exception::Lite\' }' .
|
||
|
'sub getMessage { $_[0]->[0] };' .
|
||
|
'sub getProperty { $_[0]->[1]->{$_[1]} }' .
|
||
|
'sub isProperty { exists($_[0]->[1]->{$_[1]})?1:0 }' .
|
||
|
'sub getStackTrace { $_[0]->[2] }' .
|
||
|
'sub getFrameCount { scalar(@{$_[0]->[2]}); }' .
|
||
|
'sub getFile { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[0] };' .
|
||
|
'sub getLine { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[1] };' .
|
||
|
'sub getSubroutine { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[2] };' .
|
||
|
'sub getArgs { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[3] };' .
|
||
|
'sub getPackage {$_[0]->[2]->[-1]->[2] =~ /(\w+)>$/;$1}'.
|
||
|
'sub getPid { $_[0]->[3] }' .
|
||
|
'sub getTid { $_[0]->[4] }' .
|
||
|
'sub getChained { $_[0]->[5] }' .
|
||
|
'sub getPropagation { $_[0]->[6]; }' .
|
||
|
'use overload '.
|
||
|
'q{""} => \&Exception::Lite::_dumpMessage ' .
|
||
|
', q{0+} => \&Exception::Lite::_refaddr, fallback=>1;' .
|
||
|
'sub PROPAGATE { push @{$_[0]->[6]},[$_[1],$_[2]]; $_[0]}';
|
||
|
}
|
||
|
}
|
||
|
$sDeclare .= 'return 1;';
|
||
|
|
||
|
local $SIG{__WARN__} = sub {
|
||
|
my ($p,$f,$l) = caller(2);
|
||
|
my $s=$_[0]; $s =~ s/at \(eval \d+\)\s+line\s+\d+\.//m;
|
||
|
print STDERR "$s in declareExceptionClass($sClass,...) "
|
||
|
."in file $f, line $l\n";
|
||
|
};
|
||
|
|
||
|
eval $sDeclare or do {
|
||
|
my ($p,$f,$l) = caller(1);
|
||
|
print STDERR "Can't create class $sClass at file $f, line $l\n";
|
||
|
if ($sClass =~ /\w:\w/) {
|
||
|
print STDERR "Bad class name: "
|
||
|
."At least one ':' is not doubled\n";
|
||
|
} elsif ($sClass !~ /^\w+(?:::\w+)*$/) {
|
||
|
print STDERR "Bad class name: $sClass\n";
|
||
|
} else {
|
||
|
$sDeclare=~s/(sub |use )/\n$1/g; print STDERR "$sDeclare\n";
|
||
|
}
|
||
|
};
|
||
|
|
||
|
# this needs to be separate from the eval, otherwise it never
|
||
|
# ends up in @INC or @ISA, at least in Perl 5.8.8
|
||
|
$INC{$sPath} = __FILE__;
|
||
|
eval "\@${sClass}::ISA=qw($sSuperClass);" if $sSuperClass;
|
||
|
|
||
|
return $sClass;
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub isChainable { return ref($_[0])?1:0; }
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub isException {
|
||
|
my ($e, $sClass) = @_;
|
||
|
my $sRef=ref($e);
|
||
|
return !defined($sClass)
|
||
|
? ($sRef ? isExceptionClass($sRef) : 0)
|
||
|
: $sClass eq ''
|
||
|
? ($sRef eq '' ? 1 : 0)
|
||
|
: ($sRef eq '')
|
||
|
? 0
|
||
|
: $sRef->isa($sClass)
|
||
|
?1:0;
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub isExceptionClass {
|
||
|
return defined($_[0]) && $_[0]->can('_getInterface')
|
||
|
&& ($_[0]->_getInterface() eq __PACKAGE__) ? 1 : 0;
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub onDie {
|
||
|
my $iStringify = $_[0];
|
||
|
$SIG{__DIE__} = sub {
|
||
|
$Exception::Lite::STRINGIFY=$iStringify;
|
||
|
warn 'Exception::Lite::Any'->new('Unexpected death:'.$_[0])
|
||
|
unless $^S || isException($_[0]);
|
||
|
};
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub onWarn {
|
||
|
my $iStringify = $_[0];
|
||
|
$SIG{__WARN__} = sub {
|
||
|
$Exception::Lite::STRINGIFY=$iStringify;
|
||
|
print STDERR 'Exception::Lite::Any'->new("Warning: $_[0]");
|
||
|
};
|
||
|
}
|
||
|
|
||
|
#==================================================================
|
||
|
# PRIVATE SUBROUTINES
|
||
|
#==================================================================
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub _cacheCall {
|
||
|
my $iFrame = $_[0];
|
||
|
|
||
|
my @aCaller;
|
||
|
my $aArgs;
|
||
|
|
||
|
# caller populates @DB::args if called within DB package
|
||
|
eval {
|
||
|
# this 2 line wierdness is needed to prevent Module::Build from finding
|
||
|
# this and adding it to the provides list.
|
||
|
package
|
||
|
DB;
|
||
|
|
||
|
#get rid of eval and call to _cacheCall
|
||
|
@aCaller = caller($iFrame+2);
|
||
|
|
||
|
# mark leading undefined elements as maybe shifted away
|
||
|
my $iDefined;
|
||
|
if ($#aCaller < 0) {
|
||
|
@DB::args=@ARGV;
|
||
|
}
|
||
|
$aArgs = [ map {
|
||
|
defined($_)
|
||
|
? do {$iDefined=1;
|
||
|
"'$_'" . (overload::Method($_,'""')
|
||
|
? ' ('.overload::StrVal($_).')':'')}
|
||
|
: 'undef' . (defined($iDefined)
|
||
|
? '':' (maybe shifted away?)')
|
||
|
} @DB::args];
|
||
|
};
|
||
|
|
||
|
return $#aCaller < 0 ? \$aArgs : [ @aCaller[0..3], $aArgs ];
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub _cacheStackTrace {
|
||
|
my $e=$_[0]; my $st=[];
|
||
|
|
||
|
# set up initial frame
|
||
|
my $iFrame= $STACK_OFFSET + 1; # call to new
|
||
|
my $aCall = _cacheCall($iFrame++);
|
||
|
my ($sPackage, $iFile, $iLine, $sSub, $sArgs) = @$aCall;
|
||
|
my $iLineFrame=$iFrame;
|
||
|
|
||
|
$aCall = _cacheCall($iFrame++); #context of call to new
|
||
|
while (ref($aCall) ne 'REF') {
|
||
|
$sSub = $aCall->[3]; # subroutine containing file,line
|
||
|
$sArgs = $aCall->[4]; # args used to call $sSub
|
||
|
|
||
|
#print STDERR "debug-2: package=$sPackage file=$iFile line=$iLine"
|
||
|
# ." sub=$sSub, args=@$sArgs\n";
|
||
|
|
||
|
# in evals we want the line number within the eval, but the
|
||
|
# name of the sub in which the eval was located. To get this
|
||
|
# we wait to push on the stack until we get an actual sub name
|
||
|
# and we avoid overwriting the location information, hence 'ne'
|
||
|
|
||
|
if (!$FILTER || ($sSub ne EVAL)) {
|
||
|
my $aFrame=[ $iFile, $iLine, $sSub, $sArgs ];
|
||
|
($sPackage, $iFile, $iLine) = @$aCall;
|
||
|
$iLineFrame=$iFrame;
|
||
|
|
||
|
my $sRef=ref($FILTER);
|
||
|
if ($sRef eq 'CODE') {
|
||
|
my $x = $FILTER->(@$aFrame, $iFrame, $iLineFrame);
|
||
|
if (ref($x) eq 'ARRAY') {
|
||
|
$aFrame=$x;
|
||
|
} elsif (!$x) {
|
||
|
$aFrame=undef;
|
||
|
}
|
||
|
} elsif (($sRef eq 'ARRAY') && ! _isIgnored($sSub, $FILTER)) {
|
||
|
$aFrame=undef;
|
||
|
} elsif (($sRef eq 'Regexp') && !_isIgnored($sSub, [$FILTER])) {
|
||
|
$aFrame=undef;
|
||
|
}
|
||
|
push(@$st, $aFrame) if $aFrame;
|
||
|
}
|
||
|
|
||
|
$aCall = _cacheCall($iFrame++);
|
||
|
}
|
||
|
|
||
|
push @$st, [ $iFile, $iLine, "<package: $sPackage>", $$aCall ];
|
||
|
if ($e) { my $n=$#{$e->[2]}-$#$st;$e->[2]=[@{$e->[2]}[0..$n]]};
|
||
|
return $st;
|
||
|
}
|
||
|
|
||
|
#-----------------------------
|
||
|
|
||
|
sub _isIgnored {
|
||
|
my ($sSub, $aIgnore) = @_;
|
||
|
foreach my $re (@$aIgnore) { return 1 if $sSub =~ $re; }
|
||
|
return 0;
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub _dumpMessage {
|
||
|
my ($e, $iDepth) = @_;
|
||
|
|
||
|
my $sMsg = $e->getMessage();
|
||
|
return $sMsg unless $STRINGIFY;
|
||
|
if (ref($STRINGIFY) eq 'CODE') {
|
||
|
return $STRINGIFY->($sMsg);
|
||
|
}
|
||
|
|
||
|
$iDepth = 0 unless defined($iDepth);
|
||
|
my $sIndent = ' ' x ($TAB*$iDepth);
|
||
|
$sMsg = "\n${sIndent}Exception! $sMsg";
|
||
|
return $sMsg if $STRINGIFY == 0;
|
||
|
|
||
|
my ($sThrow, $sReach);
|
||
|
my $sTab = ' ' x $TAB;
|
||
|
|
||
|
$sIndent.= $sTab;
|
||
|
if ($STRINGIFY > 2) {
|
||
|
my $aPropagation = $e->getPropagation();
|
||
|
for (my $i=$#$aPropagation; $i >= 0; $i--) {
|
||
|
my ($f,$l) = @{$aPropagation->[$i]};
|
||
|
$sMsg .= "\n${sIndent}rethrown at file $f, line $l";
|
||
|
}
|
||
|
$sMsg .= "\n";
|
||
|
$sThrow='thrown ';
|
||
|
$sReach='reached ';
|
||
|
} else {
|
||
|
$sThrow='';
|
||
|
$sReach='';
|
||
|
}
|
||
|
|
||
|
my $st=$e->getStackTrace();
|
||
|
my $iTop = scalar @$st;
|
||
|
|
||
|
for (my $iFrame=0; $iFrame<$iTop; $iFrame++) {
|
||
|
my ($f,$l,$s,$aArgs) = @{$st->[$iFrame]};
|
||
|
|
||
|
if ($iFrame) {
|
||
|
#2nd and following stack frame
|
||
|
my $sVia="${sIndent}${sReach}via file $f, line $l";
|
||
|
my $sLine="$sVia in $s";
|
||
|
$sMsg .= (length($sLine)>$LINE_LENGTH
|
||
|
? "\n$sVia\n$sIndent${sTab}in $s" : "\n$sLine");
|
||
|
} else {
|
||
|
# first stack frame
|
||
|
my $tid=$e->getTid();
|
||
|
my $sAt="${sIndent}${sThrow}at file $f, line $l";
|
||
|
my $sLine="$sAt in $s";
|
||
|
$sMsg .= (length($sLine)>$LINE_LENGTH
|
||
|
? "\n$sAt\n$sIndent${sTab}in $s" : "\n$sLine")
|
||
|
. ", pid=" . $e->getPid() . (defined($tid)?", tid=$tid":'');
|
||
|
|
||
|
return "$sMsg\n" if $STRINGIFY == 1;
|
||
|
}
|
||
|
|
||
|
if ($STRINGIFY > 3) {
|
||
|
my $bTop = ($iFrame+1) == $iTop;
|
||
|
my $sVar= ($bTop && !$iDepth) ? '@ARGV' : '@_';
|
||
|
my $bMaybeEatenByGetOpt = $bTop && !scalar(@$aArgs)
|
||
|
&& exists($INC{'Getopt/Long.pm'});
|
||
|
|
||
|
my $sVarIndent = "\n${sIndent}" . (' ' x $TAB);
|
||
|
my $sArgPrefix = "${sVarIndent}".(' ' x length($sVar)).' ';
|
||
|
if ($bMaybeEatenByGetOpt) {
|
||
|
$sMsg .= $sArgPrefix . $sVar
|
||
|
. '() # maybe eaten by Getopt::Long?';
|
||
|
} else {
|
||
|
my $sArgs = join($sArgPrefix.',', @$aArgs);
|
||
|
$sMsg .= "${sVarIndent}$sVar=($sArgs";
|
||
|
$sMsg .= $sArgs ? "$sArgPrefix)" : ')';
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
$sMsg.="\n";
|
||
|
return $sMsg if $STRINGIFY == 2;
|
||
|
|
||
|
my $eChained = $e->getChained();
|
||
|
if (defined($eChained)) {
|
||
|
my $sTrigger = isException($eChained)
|
||
|
? _dumpMessage($eChained, $iDepth+1)
|
||
|
: "\n${sIndent}$eChained\n";
|
||
|
$sMsg .= "\n${sIndent}Triggered by...$sTrigger";
|
||
|
}
|
||
|
return $sMsg;
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
# refaddr has a prototype($) so we can't use it directly as an
|
||
|
# overload operator: it complains about being passed 3 parameters
|
||
|
# instead of 1.
|
||
|
sub _refaddr { Scalar::Util::refaddr($_[0]) };
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub _rethrow {
|
||
|
my $self = shift; my $sAddOrOmit = shift;
|
||
|
my ($p,$f,$l)=caller(1);
|
||
|
$self->PROPAGATE($f,$l);
|
||
|
|
||
|
if (@_%2) {
|
||
|
warn sprintf('bad parameter list to %s->rethrow(...)'
|
||
|
.'at file %d, line %d: odd number of elements in property-value '
|
||
|
.'list, property value has no property name and will be '
|
||
|
."discarded (common causes: you have %s string)\n"
|
||
|
,$f, $l, $sAddOrOmit);
|
||
|
shift @_;
|
||
|
}
|
||
|
$self->replaceProperties({@_}) if (@_);
|
||
|
return $self;
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
# Traps warnings and reworks them so that they tell the user how
|
||
|
# to fix the problem rather than obscurely complain about an
|
||
|
# invisible sprintf with uninitialized values that seem to come from
|
||
|
# no where (and make Exception::Lite look like it is broken)
|
||
|
|
||
|
sub _sprintf {
|
||
|
my $sMsg;
|
||
|
my $sWarn;
|
||
|
|
||
|
{
|
||
|
local $SIG{__WARN__} = sub { $sWarn=$_[0] if !defined($sWarn) };
|
||
|
|
||
|
# sprintf has prototype ($@)
|
||
|
my $sFormat = shift;
|
||
|
$sMsg = sprintf($sFormat, @_);
|
||
|
}
|
||
|
|
||
|
if (defined($sWarn)) {
|
||
|
my $sReason='';
|
||
|
my ($f, $l, $s) = (caller(1))[1,2,3];
|
||
|
$s =~ s/::(\w+)\z/->$1/;
|
||
|
$sWarn =~ s/sprintf/$s/;
|
||
|
$sWarn =~ s/\s+at\s+[\w\/\.]+\s+line\s+\d+\.\s+\z//;
|
||
|
if ($sWarn
|
||
|
=~ m{^Use of uninitialized value in|^Missing argument}) {
|
||
|
my $p=$s; $p =~ s/->\w+\z//;
|
||
|
$sReason ="\n Most likely cause: "
|
||
|
. "Either you are missing property-value pairs needed to"
|
||
|
. "build the message or your exception class's format"
|
||
|
. "definition mistakenly has too many placeholders "
|
||
|
. "(e.g. %s,%d,etc)\n";
|
||
|
}
|
||
|
warn "$sWarn called at file $f, line $l$sReason\n";
|
||
|
}
|
||
|
return $sMsg;
|
||
|
}
|
||
|
|
||
|
#------------------------------------------------------------------
|
||
|
|
||
|
sub _shiftProperties {
|
||
|
my $cl= shift; my $st=shift; my $sAddOrOmit = shift;
|
||
|
if (@_%2) {
|
||
|
$"='|';
|
||
|
warn sprintf('bad parameter list to %s->new(...) at '
|
||
|
.'file %s, line %d: odd number of elements in property-value '
|
||
|
.'list, property value has no property name and will be '
|
||
|
.'discarded (common causes: you have %s string -or- you are '
|
||
|
."using a string as a chained exception)\n"
|
||
|
,$cl,$st->[0]->[0],$st->[0]->[1], $sAddOrOmit);
|
||
|
shift @_;
|
||
|
}
|
||
|
return {@_};
|
||
|
}
|
||
|
|
||
|
#==================================================================
|
||
|
# MODULE INITIALIZATION
|
||
|
#==================================================================
|
||
|
|
||
|
declareExceptionClass(__PACKAGE__ .'::Any');
|
||
|
1;
|
||
| modules/fallback/Exception/Lite.pod | ||
|---|---|---|
|
=head1 NAME
|
||
|
|
||
|
Exception::Lite - light weight exception handling class with smart
|
||
|
stack tracing, chaining, and localization support.
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# making this module available to your code
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
#Note: there are NO automatic exports
|
||
|
|
||
|
use Exception::Lite qw(declareExceptionClass
|
||
|
isException
|
||
|
isChainable
|
||
|
onDie
|
||
|
onWarn);
|
||
|
|
||
|
# imports only: declareExceptionClass isException isChainable
|
||
|
use Exception::Lite qw(:common);
|
||
|
|
||
|
# imports all exportable methods listed above
|
||
|
use Exception::Lite qw(:all);
|
||
|
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# declare an exception class
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
# no format rule
|
||
|
declareExceptionClass($sClass);
|
||
|
declareExceptionClass($sClass, $sSuperClass);
|
||
|
|
||
|
# with format rule
|
||
|
declareExceptionClass($sClass, $aFormatRule);
|
||
|
declareExceptionClass($sClass, $sSuperClass, $aFormatRule);
|
||
|
|
||
|
# with customized subclass
|
||
|
declareExceptionClass($sClass, $sSuperClass, 1);
|
||
|
declareExceptionClass($sClass, $aFormatRule, 1);
|
||
|
declareExceptionClass($sClass, $sSuperClass, $aFormatRule, 1);
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# throw an exception
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
die $sClass->new($sMsg, $prop1 => $val1, ...); #no format rule
|
||
|
die $sClass->new($prop1 => $val1, ...); #has format rule
|
||
|
|
||
|
#-or-
|
||
|
|
||
|
$e = $sClass->new($sMsg, $prop1 => $val1, ...); #no format rule
|
||
|
$e = $sClass->new($prop1 => $val1, ...); #has format rule
|
||
|
|
||
|
die $e;
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# catch and test an exception
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
# Note: for an explanation of why we don't use if ($@)... here,
|
||
|
# see Catching and Rethrowing exceptions below
|
||
|
|
||
|
eval {
|
||
|
.... some code that may die here ...
|
||
|
return 1;
|
||
|
} or do {
|
||
|
my $e=$@;
|
||
|
|
||
|
if (isException($e, 'Class1')) {
|
||
|
... do something ...
|
||
|
} elsif (isExcption($e, 'Class2')) {
|
||
|
... do something else ...
|
||
|
}
|
||
|
};
|
||
|
|
||
|
isException($e); # does $e have the above exception methods?
|
||
|
isException($e,$sClass) # does $e belong to $sClass or a subclass?
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# getting information about an exception object
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
$e->getMessage();
|
||
|
$e->getProperty($sName);
|
||
|
$e->isProperty($sName);
|
||
|
$e->replaceProperties($hOverride);
|
||
|
|
||
|
$e->getPid();
|
||
|
$e->getPackage();
|
||
|
$e->getTid();
|
||
|
|
||
|
$e->getStackTrace();
|
||
|
$e->getFrameCount();
|
||
|
$e->getFile($i);
|
||
|
$e->getLine($i);
|
||
|
$e->getSubroutine($i);
|
||
|
$e->getArgs($i);
|
||
|
|
||
|
$e->getPropagation();
|
||
|
$e->getChained();
|
||
|
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# rethrowing exceptions
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
# using original properties and message
|
||
|
|
||
|
$@=$e; die; # pure Perl way (reset $@ in case wiped out)
|
||
|
|
||
|
die $e->rethrow(); # same thing, but a little less cryptic
|
||
|
|
||
|
|
||
|
# overriding original message/properties
|
||
|
|
||
|
die $e->rethrow(path=>$altpath, user=>$nameReplacingId);
|
||
|
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# creation of chained exceptions (one triggered by another)
|
||
|
# (new exception with "memory" of what caused it and stack
|
||
|
# trace from point of cause to point of capture)
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
isChainable($e); # can $e be used as a chained exception?
|
||
|
|
||
|
die $sClass->new($e, $sMsg, $prop1 => $val1, ...);#no format rule
|
||
|
die $sClass->new($e, $prop1 => $val1, ...); #has format rule
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# print out full message from an exception
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
print $e # print works
|
||
|
warn $e # warn works
|
||
|
print "$e\n"; # double quotes work
|
||
|
my $sMsg=$e."\n"; print $sMsg; # . operator works
|
||
|
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# global control variables (maybe set on the command line)
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
$Exception::Lite::STRINGIFY #set rule for stringifying messages
|
||
|
|
||
|
= 1; # message and file/line where it occured
|
||
|
= 2; # 1 + what called what (simplified stack trace)
|
||
|
= 3; # 2 + plus any chained exceptions and where message
|
||
|
# was caught, if propagated and rethrown
|
||
|
= 4; # 3 + arguments given to each call in stack trace
|
||
|
= coderef # custom formatting routine
|
||
|
|
||
|
$Exception::Lite::TAB # set indentation for stringified
|
||
|
# messages, particularly indentation for
|
||
|
# call parameters and chained exceptions
|
||
|
|
||
|
$Exception::Lite::FILTER
|
||
|
= 0 # see stack exactly as Perl does
|
||
|
= 1 # remove frames added by eval blocks
|
||
|
= coderef # custom filter - see getStackTrace for details
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# controlling the stack trace from the command line
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
perl -mException::Lite=STRINGIFY=1,FILTER=0,TAB=4
|
||
|
perl -m'Exception::Lite qw(STRINGIFY=1 FILTER=0 TAB=4)'
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# built in exception classes
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
# generic wrapper for converting exception strings and other
|
||
|
# non-Exception::Lite exceptions into exception objects
|
||
|
|
||
|
Exception::Class::Any->new($sMessageText);
|
||
|
|
||
|
To assist in debugging and testing, this package also includes
|
||
|
two methods that set handlers for die and warn. These methods
|
||
|
should I<only> be used temporarily during active debugging. They
|
||
|
should not be used in production software, least they interfere
|
||
|
with the way other programmers using your module wish to do their
|
||
|
debugging and testing.
|
||
|
|
||
|
# --------------------------------------------------------
|
||
|
# force all exceptions/warnings to use Exception::Lite to
|
||
|
# print out messages and stack traces
|
||
|
# --------------------------------------------------------
|
||
|
|
||
|
# $stringify is the value for EXCEPTION::Lite::STRINGIFY
|
||
|
# that you want to use locally to print out messages. It
|
||
|
# will have no effect outside of the die handler
|
||
|
|
||
|
Exception::Lite::onDie($stringify);
|
||
|
Exception::Lite::onWarn($stringify);
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
The C<Exception::Lite> class provides an easy and very light weight
|
||
|
way to generate context aware exceptions. It was developed because
|
||
|
the exception modules on CPAN as of December,2010 were heavy on
|
||
|
features I didn't care for and did not have the features I most
|
||
|
needed to test and debug code efficiently.
|
||
|
|
||
|
=head2 Features
|
||
|
|
||
|
This module provides a light weight but powerful exception class
|
||
|
that
|
||
|
|
||
|
=over
|
||
|
|
||
|
=item *
|
||
|
|
||
|
provides an uncluttered stack trace that clearly shows what
|
||
|
called what and what exception triggered what other exception.
|
||
|
It significantly improves on the readability of the stack trace
|
||
|
dumps provided by C<carp> and other exception modules on
|
||
|
CPAN (as of 12/2010). For further discussion and a sample, see
|
||
|
L</More intelligent stack trace>.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
gives the user full control over the amount of debugging
|
||
|
information displayed when exceptions are thrown.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
permits global changes to the amount of debugging information
|
||
|
displayed via the command line.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
closely integrates exception classes, messages, and properties
|
||
|
so that they never get out of sync with one another. This in
|
||
|
turn eliminates redundant coding and helps reduce the cost of
|
||
|
writing,validating and maintaining a set of exceptions.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
is easy to retrofit with native language support, even if this
|
||
|
need appears late in the development process.This makes it
|
||
|
suitable for use with agile development strategies.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
act like strings in string context but are in fact objects with
|
||
|
a class hierarchy and properties.They can be thrown and rethrown
|
||
|
with standard Perl syntax. Like any object, they can be uniquely
|
||
|
identified in numeric context where they equal their reference
|
||
|
address (the value returned by C<Scalar::Util::refaddr()>.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
does not interfere with signal handlers or the normal Perl syntax
|
||
|
and the assumptions of Perl operators.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
can be easily extended and subclassed
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head2 Lightweight how?
|
||
|
|
||
|
Despite these features C<Exception::Lite> maintains its "lite"
|
||
|
status by
|
||
|
|
||
|
=over
|
||
|
|
||
|
=item *
|
||
|
|
||
|
using only core modules
|
||
|
|
||
|
=item *
|
||
|
|
||
|
generating tiny exception classes (30-45LOC per class).
|
||
|
|
||
|
=item *
|
||
|
|
||
|
eliminating excess baggage by customizing generated classes to
|
||
|
reflect the actual needs of exception message generation. For
|
||
|
instance an exception wrapped around a fixed string message would
|
||
|
omit code for message/property integration and would be little
|
||
|
more than a string tied to a stack trace and property hash.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
storing only the minimum amount of stack trace data needed to
|
||
|
generate exception messages and avoiding holding onto references
|
||
|
from dead stack frames. (Note: some CPAN modules hold onto
|
||
|
actual variables from each frame, possibly interfering with
|
||
|
garbage collection).
|
||
|
|
||
|
=item *
|
||
|
|
||
|
doing all its work, including class generation and utilities in
|
||
|
a single file that is less than half the size of the next smallest
|
||
|
similarly featured all-core exception class on CPAN (support for
|
||
|
both properties and a class heirarchy). C<Exception::Lite>
|
||
|
contains about 400 lines when developer comments are excluded). The
|
||
|
next smallest all core module is L<Exception::Base|Exception::Base>
|
||
|
which clocks in at just over 1000 lines after pod and developer
|
||
|
comments are excluded).
|
||
|
|
||
|
=item *
|
||
|
|
||
|
avoiding a heavy-weight base class. Code shared by
|
||
|
C<Exception::Lite> classes are stored in function calls that total
|
||
|
230 or so lines of code relying on nothing but core modules. This
|
||
|
is significantly less code than is needed by the two CPAN packages
|
||
|
with comparable features. The all core
|
||
|
L<Exception::Base|Exception::Base> class contains 700+ lines of
|
||
|
code. The base class of L<Exception::Class|Exception::Class> has
|
||
|
200 lines of its own but drags in two rather large non-core
|
||
|
modules as dependencies: L<Devel::StackTrace|Devel::StackTrace>
|
||
|
L<Class::Data::Inheritable|Class::Data::Inheritable>.
|
||
|
|
||
|
=back
|
||
|
|
||
|
C<Exception::Lite> has more features (chaining, message/property
|
||
|
integration) but less code due to the following factors:
|
||
|
|
||
|
=over
|
||
|
|
||
|
=item *
|
||
|
|
||
|
working with Perl syntax rather than trying to replace it.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
using a light approach to OOP - exception classes have just enough
|
||
|
and no more OO features than are needed to be categorized by a
|
||
|
class, participate in a class heirarchy and to have properties.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
respecting separation of concerns. C<Exception::Lite> focuses
|
||
|
on the core responsibility of an exception and leaves the bulk of
|
||
|
syntax creation (e.g. Try/Catch) to specialist modules like
|
||
|
L<Try::Tiny|Try::Tiny>. Other modules try to double as
|
||
|
comprehensive providers of exception related syntactic sugar.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
not trying to be the only kind of exception that an application
|
||
|
uses.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 USAGE
|
||
|
|
||
|
=head2 Defining Exception Classes
|
||
|
|
||
|
C<Exception::Lite> provides two different ways to define messages.
|
||
|
The first way, without a format rule, lets you compose a freeform
|
||
|
message for each exception. The second way, with a format rule,
|
||
|
lets you closely integrate messages and properties and facilitates
|
||
|
localization of messages for any packages using your software.
|
||
|
|
||
|
=head3 Defining freeform messages
|
||
|
|
||
|
If you want to compose a free form message for each and every
|
||
|
exception, the class declaration is very simple:
|
||
|
|
||
|
declareExceptionClass($sClass);
|
||
|
declareExceptionClass($sClass, $sSuperClass);
|
||
|
|
||
|
# with customized subclass
|
||
|
declareExceptionClass($sClass, $sSuperClass, 1);
|
||
|
|
||
|
C<$sClass> is the name of the exception class.
|
||
|
|
||
|
C<$sSuperClass> is the name of the superclass, if there is one.
|
||
|
The superclass can be any class created by C<Exception::Lite>. It
|
||
|
can also be any role class, i.e. a class that has methods but no
|
||
|
object data of its own.
|
||
|
|
||
|
The downside of this simple exception class is that there is
|
||
|
absolutely no integration of your messages and any properties that
|
||
|
you assign to the exception. If you would like to see your property
|
||
|
values included in the message string,consider using a formatted
|
||
|
message instead.
|
||
|
|
||
|
=head3 Defining formatted messages
|
||
|
|
||
|
If you wish to include property values in your messages, you need
|
||
|
to declare a formatted message class. To do this, you define a
|
||
|
format rule and pass it to the constructor:
|
||
|
|
||
|
$aFormatRule = ['Cannot copy %s to %s', qw(from to) ];
|
||
|
|
||
|
declareExceptionClass($sClass, $aFormatRule);
|
||
|
declareExceptionClass($sClass, $sSuperClass, $aFormatRule);
|
||
|
|
||
|
# with customized subclass
|
||
|
declareExceptionClass($sClass, $aFormatRule, 1);
|
||
|
declareExceptionClass($sClass, $sSuperClass, $aFormatRule, 1);
|
||
|
|
||
|
Format rules are nothing more than a sprintf message string
|
||
|
followed by a list of properties in the same order as the
|
||
|
placeholders in the message string. Later on when an exception
|
||
|
is generated, the values of the properties will replace the
|
||
|
property names. Some more examples of format rules:
|
||
|
|
||
|
|
||
|
$aFormatRule = ['Illegal argument <%s>: %s', qw(arg reason)];
|
||
|
declareExceptionClass('BadArg', $aFormatRule);
|
||
|
|
||
|
$aFormatRule = ['Cannot open file <%s>> %s', qw(file reason)];
|
||
|
declareExceptionClass('OpenFailed', $aFormatRule);
|
||
|
|
||
|
$sFormatRule = ['Too few %s, must be at least %s', qw(item min)];
|
||
|
declareExceptionClass('TooFewWidgets', $aFormatRule);
|
||
|
|
||
|
|
||
|
Later on when you throw an exception you can forget about the message
|
||
|
and set the properties, the class will do the rest of the work:
|
||
|
|
||
|
die BadArg->new(arg=>$sPassword, reason=>'Too few characters');
|
||
|
|
||
|
|
||
|
open(my $fh, '>', $sFile)
|
||
|
or die OpenFailed->new(file=>$sFile, reason=>$!);
|
||
|
|
||
|
And still later when you catch the exception, you have two kinds
|
||
|
of information for the price of one:
|
||
|
|
||
|
# if you catch BadArg
|
||
|
|
||
|
$e->getProperty('arg') # mine
|
||
|
$e->getProperty('reason') # too few characters
|
||
|
$e->getMessage() # Illegal argument <mine>: too few characters
|
||
|
|
||
|
|
||
|
# if you catch OpenFailed
|
||
|
|
||
|
$e->getProperty('file') # foo.txt
|
||
|
$e->getProperty('reason') # path not found
|
||
|
$e->getMessage() # Cannot open <foo.txt>: path not found
|
||
|
|
||
|
|
||
|
=head2 Creating and throwing exceptions
|
||
|
|
||
|
When it comes times to create an exception, you create and
|
||
|
throw it like this (C<$sClass> is a placeholder for the name of
|
||
|
your exception class);
|
||
|
|
||
|
|
||
|
die $sClass->new($sMsg, prop1 => $val1, ...); #no format rule
|
||
|
die $sClass->new(prop1 => $val1, ...); #has format rule
|
||
|
|
||
|
#-or-
|
||
|
|
||
|
$e = $sClass->new($sMsg, prop1 => $val1, ...); #no format rule
|
||
|
$e = $sClass->new(prop1 => $val1, ...); #has format rule
|
||
|
|
||
|
die $e;
|
||
|
|
||
|
|
||
|
For example:
|
||
|
|
||
|
# Freeform exceptions (caller composes message, has message
|
||
|
# parameter ($sMsg) before the list of properties)
|
||
|
|
||
|
close $fh or die UnexpectedException
|
||
|
->new("Couldn't close file handle (huh?): $!");
|
||
|
|
||
|
die PropertySettingError("Couldn't set property"
|
||
|
, prop=>foo, value=>bar);
|
||
|
|
||
|
# Formatted exceptions (no $sMsg parameter)
|
||
|
|
||
|
if (length($sPassword) < 8) {
|
||
|
die BadArg->new(arg=>$sPassword, reason=>'Too few characters');
|
||
|
}
|
||
|
|
||
|
open(my $fh, '>', $sFile)
|
||
|
or die OpenFailed->new(file=>$sFile, reason=>$!);
|
||
|
|
||
|
In the above examples the order of the properties does not matter.
|
||
|
C<Exception::Lite> is using the property names, not the order of
|
||
|
the properties to find the right value to plug into the message
|
||
|
format string.
|
||
|
|
||
|
=head2 Catching and testing exceptions
|
||
|
|
||
|
In Perl there are two basic ways to work with exceptions:
|
||
|
|
||
|
* native Perl syntax
|
||
|
|
||
|
* Java like syntax (requires non-core modules)
|
||
|
|
||
|
=head3 Catching exceptions the Java way
|
||
|
|
||
|
Java uses the following idiom to catch exceptions:
|
||
|
|
||
|
try {
|
||
|
.... some code here ...
|
||
|
} catch (SomeExceptionClass e) {
|
||
|
... error handling code here ...
|
||
|
} catch (SomeOtherExceptionClass e) {
|
||
|
... error handling code here ...
|
||
|
} finally {
|
||
|
... cleanup code here ...
|
||
|
}
|
||
|
|
||
|
There are several CPAN modules that provide some sort of syntactic
|
||
|
sugar so that you can emulate java syntax. The one recommended
|
||
|
for C<Exception::Lite> users is L<Try::Tiny|Try::Tiny>.
|
||
|
L<Try::Tiny|Try::Tiny> is an elegant class that concerns itself
|
||
|
only with making it possible to use java-like syntax. It can be
|
||
|
used with any sort of exception.
|
||
|
|
||
|
Some of the other CPAN modules that provide java syntax also
|
||
|
require that you use their exception classes because the java like
|
||
|
syntax is part of the class definition rather than a pure
|
||
|
manipulation of Perl syntax.
|
||
|
|
||
|
|
||
|
=head3 Catching exceptions the Perl way
|
||
|
|
||
|
The most reliable and fastest way to catch an exception is to use
|
||
|
C< eval/do >:
|
||
|
|
||
|
eval {
|
||
|
...
|
||
|
return 1;
|
||
|
} or do {
|
||
|
# save $@ before using it - it can easily be clobbered
|
||
|
my $e=$@;
|
||
|
|
||
|
... do something with the exception ...
|
||
|
|
||
|
warn $e; #use $e as a string
|
||
|
warn $e->getMessage(); # use $e as an object
|
||
|
}
|
||
|
|
||
|
|
||
|
The C<eval> block ends with C<return 1;> to insure that successful
|
||
|
completion of the eval block never results in an undefined value.
|
||
|
In certain cases C<undef> is a valid return value for a statement,
|
||
|
We don't want to enter the C<do> block for any reason other than
|
||
|
a thrown exception.
|
||
|
|
||
|
C< eval/do > is both faster and more reliable than the C< eval/if>
|
||
|
which is commonly promoted in Perl programming tutorials:
|
||
|
|
||
|
# eval ... if
|
||
|
|
||
|
eval {...};
|
||
|
if ($@) {....}
|
||
|
|
||
|
It is faster because the C<do> block is executed if and only
|
||
|
if the eval fails. By contrast the C<if> must be evaluated both
|
||
|
in cases of succes and failure.
|
||
|
|
||
|
C< eval/do > is more reliable because the C<do> block is guaranteed
|
||
|
to be triggered by any die, even one that accidentally throws undef
|
||
|
or '' as the "exception". If an exception is thrown within the C<eval>
|
||
|
block, it will always evaluate to C<undef> therefore triggering the
|
||
|
C<do> block.
|
||
|
|
||
|
On the other hand we can't guarentee that C<$@> will be defined
|
||
|
even if an exception is thrown. If C<$@> is C<0>, C<undef>, or an
|
||
|
empty string, the C<if> block will never be entered. This happens
|
||
|
more often then many programmers realize. When eval exits the
|
||
|
C< eval > block, it calls destructors of any C<my> variables. If
|
||
|
any of those has an C< eval > statement, then the value of C<$@> is
|
||
|
wiped clean or reset to the exception generated by the destructor.
|
||
|
|
||
|
Within the C<do> block, it is a good idea to save C<$@> immediately
|
||
|
into a variable before doing any additional work. Any subroutine
|
||
|
you call might also clobber it. Even built-in commands that don't
|
||
|
normally set C<$@> can because Perl lets a programmer override
|
||
|
built-ins with user defined routines and those user define routines
|
||
|
might set C<$@> even if the built-in does not.
|
||
|
|
||
|
=head3 Testing exceptions
|
||
|
|
||
|
Often when we catch an exception we want to ignore some, rethrow
|
||
|
others, and in still other cases, fix the problem. Thus we need a
|
||
|
way to tell what kind of exception we've caught. C<Exception::Lite>
|
||
|
provides the C<isException> method for this purpose. It can be
|
||
|
passed any exception, including scalar exceptions:
|
||
|
|
||
|
# true if this exception was generated by Exception::Line
|
||
|
isException($e);
|
||
|
|
||
|
|
||
|
# true if this exception belongs to $sClass. It may be a member
|
||
|
# of the class or a subclass. C<$sClass> may be any class, not
|
||
|
# just an Exception::Lite generated class. You can even use this
|
||
|
# method to test for string (scalar) exceptions:
|
||
|
|
||
|
isException($e,$sClass);
|
||
|
|
||
|
isException($e,'Excption::Class');
|
||
|
isException($e, 'BadArg');
|
||
|
isException($e, '');
|
||
|
|
||
|
And here is an example in action. It converts an exception to a
|
||
|
warning and determines how to do it by checing the class.
|
||
|
|
||
|
|
||
|
eval {
|
||
|
...
|
||
|
return 1;
|
||
|
} or do {
|
||
|
my $e=$@;
|
||
|
if (Exception::Lite::isException($e)) {
|
||
|
|
||
|
# get message w/o stack trace, "$e" would produce trace
|
||
|
warn $e->getMessage();
|
||
|
|
||
|
} elsif (Exception::Lite::isException('Exception::Class') {
|
||
|
|
||
|
# get message w/o stack trace, "$e" would produce trace
|
||
|
warn $e->message();
|
||
|
|
||
|
} elsif (Exception::Lite::isException($e,'')) {
|
||
|
|
||
|
warn $e;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
=head2 Rethrowing exceptions
|
||
|
|
||
|
Perl doesn't have a C<rethrow> statement. To reliably rethrow an
|
||
|
exception, you must set C<$@> to the original exception (in case it
|
||
|
has been clobbered during the error handling process) and then call
|
||
|
C<die> without any arguments.
|
||
|
|
||
|
eval {
|
||
|
...
|
||
|
return 1;
|
||
|
} or do {
|
||
|
my $e=$@;
|
||
|
|
||
|
# do some stuff
|
||
|
|
||
|
# rethrow $e
|
||
|
$@=$e; die;
|
||
|
}
|
||
|
|
||
|
The above code will cause the exception's C<PROPAGATE> method to
|
||
|
record the file and line number where the exception is rethrown.
|
||
|
See C<getLine>, C<getFile>, and C<getPropagation> in the class
|
||
|
reference below for more information.
|
||
|
|
||
|
As this Perl syntax is not exactly screaming "I'm a rethrow",
|
||
|
C<Exception::Lite> provides an alternative and hopefully more
|
||
|
intuitive way of propagating an exception. There is no magic here,
|
||
|
it just does what perl would do had you used the normal syntax,
|
||
|
i.e. call the exception's C<PROPAGATE> method.
|
||
|
|
||
|
eval {
|
||
|
...
|
||
|
return 1;
|
||
|
} or do {
|
||
|
my $e=$@;
|
||
|
|
||
|
# rethrow $e
|
||
|
die $e->rethrow();
|
||
|
}
|
||
|
|
||
|
=head2 Chaining Messages
|
||
|
|
||
|
As an exception moves up the stack, its meaning may change. For
|
||
|
example, suppose a subroutine throws the message "File not open".
|
||
|
The immediate caller might be able to use that to try and open
|
||
|
a different file. On the other hand, if the message gets thrown
|
||
|
up the stack, the fact that a file failed to open might not
|
||
|
have any meaning at all. That higher level code only cares that
|
||
|
the data it needed wasn't available. When it notifies the user,
|
||
|
it isn't going to say "File not found", but "Can't run market
|
||
|
report: missing data feed.".
|
||
|
|
||
|
When the meaning of the exception changes, it is normal to throw
|
||
|
a new exception with a class and message that captures the new
|
||
|
meaning. However, if this is all we do, we lose the original
|
||
|
source of the problem.
|
||
|
|
||
|
Enter chaining. Chaining is the process of making one exception
|
||
|
"know" what other exception caused it. You can create a new
|
||
|
exception without losing track of the original source of the
|
||
|
problem.
|
||
|
|
||
|
To chain exceptions is simple: just create a new exception and
|
||
|
pass the caught exception as the first parameter to C<new>. So
|
||
|
long as the exception is a non-scalar, it will be interpreted
|
||
|
as a chained exception and not a property name or message text
|
||
|
(the normal first parameter of C<new>).
|
||
|
|
||
|
Chaining is efficient, especially if the chained exception is
|
||
|
another C<Exception::Lite> exception. It does not replicate
|
||
|
the stack trace. Rather the original stack trace is shorted to
|
||
|
include only the those fromes frome the time it was created to
|
||
|
the time it was chained.
|
||
|
|
||
|
Any non-scalar exception can be chained. To test whether or not
|
||
|
a caught exception is chainable, you can use the method
|
||
|
C<isChainable>. This method is really nothing more than
|
||
|
a check to see if the exception is a non-scalar, but it helps
|
||
|
to make your code more self documenting if you use that method
|
||
|
rather than C<if (ref($e))>.
|
||
|
|
||
|
If an exception isn't chainable, and you still want to chain
|
||
|
it, you can wrap the exception in an exception class. You
|
||
|
can use the built-in C<Exception::Class::Any> or any class of
|
||
|
your own choosing.
|
||
|
|
||
|
#-----------------------------------------------------
|
||
|
# define some classes
|
||
|
#-----------------------------------------------------
|
||
|
|
||
|
# no format rule
|
||
|
declareExceptionClass('HouseholdDisaster');
|
||
|
|
||
|
# format rule
|
||
|
declareExceptionClass('ProjectDelay'
|
||
|
, ['The project was delayed % days', qw(days)]);
|
||
|
|
||
|
#-----------------------------------------------------
|
||
|
# chain some exceptins
|
||
|
#-----------------------------------------------------
|
||
|
|
||
|
eval {
|
||
|
.... some code here ...
|
||
|
return 1;
|
||
|
} or do {
|
||
|
my $e=$@;
|
||
|
if (Exception::Lite::isChainable($e)) {
|
||
|
if (Exception::Lite::isException($e, 'FooErr') {
|
||
|
die 'SomeNoFormatException'->new($e, "Caught a foo");
|
||
|
} else {
|
||
|
die 'SomeFormattedException'->new($e, when => 'today');
|
||
|
}
|
||
|
} elsif ($e =~ /fire/) {
|
||
|
die 'Exception::Lite::Any'->new($e);
|
||
|
die 'SomeFormattedException'->new($e, when => 'today');
|
||
|
} else {
|
||
|
# rethrow it since we can't chain it
|
||
|
$@=$e; die;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
=head2 Reading Stack Traces
|
||
|
|
||
|
At its fullest level of detail, a stack trace looks something
|
||
|
like this:
|
||
|
|
||
|
Exception! Mayhem! and then ...
|
||
|
|
||
|
thrown at file Exception/Lite.t, line 307
|
||
|
in main::weKnowBetterThanYou, pid=24986, tid=1
|
||
|
@_=('ARRAY(0x83a8a90)'
|
||
|
,'rot, rot, rot'
|
||
|
,'Wikerson brothers'
|
||
|
,'triculous tripe'
|
||
|
,'There will be no more talking to hoos who are not!'
|
||
|
,'black bottom birdie'
|
||
|
,'from the three billionth flower'
|
||
|
,'Mrs Tucanella returns with uncles and cousins'
|
||
|
,'sound off! sound off! come make yourself known!'
|
||
|
,'Apartment 12J'
|
||
|
,'Jo Jo the young lad'
|
||
|
,'the whole world was saved by the smallest of all'
|
||
|
)
|
||
|
reached via file Exception/Lite.t, line 281
|
||
|
in main::notAWhatButAWho
|
||
|
@_=()
|
||
|
reached via file Exception/Lite.t, line 334 in main::__ANON__
|
||
|
@_=()
|
||
|
reached via file Exception/Lite.t, line 335 in <package: main>
|
||
|
@ARGV=()
|
||
|
|
||
|
Triggered by...
|
||
|
Exception! Horton hears a hoo!
|
||
|
rethrown at file Exception/Lite.t, line 315
|
||
|
|
||
|
thrown at file Exception/Lite.t, line 316
|
||
|
in main::horton, pid=24986, tid=1
|
||
|
@_=('15th of May'
|
||
|
,'Jungle of Nool'
|
||
|
,'a small speck of dust on a small clover'
|
||
|
,'a person's a person no matter how small'
|
||
|
)
|
||
|
reached via file Exception/Lite.t, line 310 in main::hoo
|
||
|
@_=('Dr Hoovey'
|
||
|
,'hoo-hoo scope'
|
||
|
,'Mrs Tucanella'
|
||
|
,'Uncle Nate'
|
||
|
)
|
||
|
reached via file Exception/Lite.t, line 303
|
||
|
in main::weKnowBetterThanYou
|
||
|
@_=('ARRAY(0x83a8a90)'
|
||
|
,'rot, rot, rot'
|
||
|
,'Wikerson brothers'
|
||
|
,'triculous tripe'
|
||
|
,'There will be no more talking to hoos who are not!'
|
||
|
,'black bottom birdie'
|
||
|
,'from the three billionth flower'
|
||
|
,'Mrs Tucanella returns with uncles and cousins'
|
||
|
,'sound off! sound off! come make yourself known!'
|
||
|
,'Apartment 12J'
|
||
|
,'Jo Jo the young lad'
|
||
|
,'the whole world was saved by the smallest of all'
|
||
|
)
|
||
|
|
||
|
|
||
|
=over
|
||
|
|
||
|
=item *
|
||
|
|
||
|
lines begining with "thrown" indicate a line where a new exception
|
||
|
was thrown. If an exception was chained, there might be multiple
|
||
|
such lines.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
lines beginning with "reached via" indicate the path travelled
|
||
|
I<down> to the point where the exception was thrown. This is the
|
||
|
code that was excuted before the exception was triggered.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
lines beginning with "rethrown at" indicate the path travelled
|
||
|
I<up> the stack by the exception I<after> it was geenerated. Each
|
||
|
line indicates a place where the exception was caught and rethrown.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
lines introduced with "Triggered by" are exceptions that were
|
||
|
chained together. The original exception is the last of the
|
||
|
triggered exceptions. The original line is the "thrown" line
|
||
|
for the original exception.
|
||
|
|
||
|
=item *
|
||
|
|
||
|
C<@_> and <C@ARGV> below a line indicates what is left of the
|
||
|
parameters passed to a method, function or entry point routine.
|
||
|
In ideal circumstances they are the parameters passed to the
|
||
|
subroutine mentioned in the line immediately above C<@_>. In
|
||
|
reality, they can be overwritten or shifted away between the
|
||
|
point when the subroutine started and the line was reached.
|
||
|
|
||
|
Note: if you use L<Getopt::Long> to process C<@ARGV>, C<@ARGV>
|
||
|
will be empty reduced to an empty array. If this bothers you, you
|
||
|
can localize <@ARGV> before calling C<GetOptions>, like this:
|
||
|
|
||
|
my %hARGV;
|
||
|
{
|
||
|
local @ARGV = @ARGV;
|
||
|
GetOptions(\%hARGV,...);
|
||
|
}
|
||
|
|
||
|
=item *
|
||
|
|
||
|
pid is the process id where the code was running
|
||
|
|
||
|
=item *
|
||
|
|
||
|
tid is the thread id where the code was running
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 SPECIAL TOPICS
|
||
|
|
||
|
=head2 Localization of error messages
|
||
|
|
||
|
Rather than treat the error message and properties as entirely
|
||
|
separate entities, it gives you the option to define a format string
|
||
|
that will take your property values and insert them automatically
|
||
|
into your message. Thus when you generate an exception, you can
|
||
|
specify only the properties and have your message automatically
|
||
|
generated without any need to repeat the property values in messy
|
||
|
C<sprintf>'s that clutter up your program.
|
||
|
|
||
|
One can localize from the very beginning when one declares the
|
||
|
class or later on after the fact if you are dealing with legacy
|
||
|
software or developing on an agile module and only implementing
|
||
|
what you need now.
|
||
|
|
||
|
To localize from the get-go:
|
||
|
|
||
|
# myLookupSub returns the arguments to declareException
|
||
|
# e.g. ('CopyError', [ 'On ne peut pas copier de %s a %s'
|
||
|
, qw(from to)])
|
||
|
|
||
|
declareExceptionClass( myLookupSub('CopyError', $ENV{LANG}) );
|
||
|
|
||
|
|
||
|
# .... later on, exception generation code doesn't need to
|
||
|
# know or care about the language. it just sets the properties
|
||
|
|
||
|
|
||
|
# error message depends on locale:
|
||
|
# en_US: 'Cannot copy A.txt to B.txt'
|
||
|
# fr_FR: 'On ne peut pas copier de A.txt a B.txt'
|
||
|
# de_DE: 'Kann nicht kopieren von A.txt nach B.txt'
|
||
|
|
||
|
die 'CopyError'->new(from => 'A.txt', to => 'B.txt');
|
||
|
|
||
|
|
||
|
Another alternative if you wish to localize from the get-go is
|
||
|
to pass a code reference instead of a format rule array. In this
|
||
|
case, C<Exception::Lite> will automatically pass the class name
|
||
|
to the subroutine and retrieve the value returned.
|
||
|
|
||
|
|
||
|
# anothherLookupSub has parameters ($sClass) and returns
|
||
|
# a format array, for example:
|
||
|
#
|
||
|
# %LOCALE_FORMAT_HASH = (
|
||
|
# CopyError => {
|
||
|
# en_US => ['Cannot copy %s to %s', qw(from to)]
|
||
|
# ,fr_FR => ['On ne peut pas copier de %s a %s', qw(from to)]
|
||
|
# ,de_DE => ['Kann nicht kopieren von %s nach %s''
|
||
|
# , qw(from to)]
|
||
|
#
|
||
|
# AddError => ...
|
||
|
# );
|
||
|
#
|
||
|
# sub anotherLookupSub {
|
||
|
# my ($sClass) = @_;
|
||
|
# my $sLocale = $ENV{LANG}
|
||
|
# return $LOCALE_FORMAT_HASH{$sClass}{$sLocale};
|
||
|
# }
|
||
|
#
|
||
|
|
||
|
declareExceptionClass('CopyError', &anotherLookupSub);
|
||
|
declareExceptionClass('AddError', &anotherLookupSub);
|
||
|
|
||
|
|
||
|
# error message depends on locale:
|
||
|
# en_US: 'Cannot copy A.txt to B.txt'
|
||
|
# fr_FR: 'On ne peut pas copier de A.txt a B.txt'
|
||
|
# de_DE: 'Kann nicht kopieren von A.txt nach B.txt'
|
||
|
|
||
|
die CopyError->new(from => 'A.txt', to => 'B.txt');
|
||
|
die AddError->new(path => 'C.txt');
|
||
|
|
||
|
|
||
|
If you need to put in localization after the fact, perhaps for a
|
||
|
new user interface you are developing, the design pattern might
|
||
|
look like this:
|
||
|
|
||
|
# in the code module you are retrofitting would be an exception
|
||
|
# that lived in a single language world.
|
||
|
|
||
|
declareExceptionClass('CopyError'
|
||
|
['Cannot copy %s to %s', [qw(from to)]);
|
||
|
|
||
|
|
||
Auch abrufbar als: Unified diff
Exception::Lite als neues Standard-Exception-Modul in Fallback-Module aufgenommen