+++ /dev/null
-# 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;
projects / kivitendo-erp.git / blobdiff