Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??

Code posted below.

# Copyright (c) 2010 Elizabeth Grace Frank-Backman. # All rights reserved. # # Liscenced under the "Artistic Liscence" # (see http://dev.perl.org/licenses/artistic.html) use strict; use warnings; package Exception::Lite; our @ISA = qw(Exporter); our @EXPORT_OK=qw(declareExceptionClass isException isChainable); my $CLASS='Exception::Lite'; #------------------------------------------------------------------ our $STRINGIFY=3; our $TAB=3; our $FILTER=1; our $UNDEF='<undef>'; # 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 'TAB') { $TAB=$v; } 0; } else { 1; } } @_); } #------------------------------------------------------------------ use Scalar::Util (); use threads; our $MSG_BAD_NEW_PARAMS = 'bad parameter list to %s->new(...) 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 -or- you are using a string as a chained '. "exception)\n"; our $MSG_BAD_RETHROW_PARAMS = '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"; #================================================================== # EXPORTABLE FUNCTIONS #================================================================== #------------------------------------------------------------------ # Generate exception class sub declareExceptionClass { my ($sClass, $sSuperClass, $xFormatRule, $bCustomizeSubclass) = @_; my $sRef=ref($sSuperClass); if ($sRef) { $bCustomizeSubclass = $xFormatRule; $xFormatRule = $sSuperClass; } else { $sRef = ref($xFormatRule); } # set up things dependent on whether or not the class has a # format string or expects a message for each instance my ($sOptionalParams, $sAddOrOmit, $sRethrowMsg,$sMakeMsg , $sReplaceMsg); if ($sRef) { #generate format data $xFormatRule=$xFormatRule->($sClass) if ($sRef eq 'CODE'); my $sFormat=$xFormatRule->[0]; $sOptionalParams='my $e; $e=shift if ref($_[0]);'; $sAddOrOmit='added an unnecessary message or format'; my $sSprintf = 'sprintf(\'' . $sFormat . '\', map {defined($_)?$_:\''. $UNDEF .'\'} @$h{qw(' . join(' ', @$xFormatRule[1..$#$xFormatRule]) . ')});'; $sMakeMsg='my $msg='.$sSprintf; $sRethrowMsg=''; $sReplaceMsg='$_[0]->[0]='.$sSprintf; } else { $sOptionalParams = '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'; $sMakeMsg=''; $sRethrowMsg='my $msg=shift; $_[0]->[0]=$msg if defined($msg);'; $sReplaceMsg=''; } my $sPath = $sClass; $sPath =~ s/::/\//g; my $sDeclare = "package $sClass; \$INC{'$sPath.pm'}=".__FILE__.";" . 'sub new { my $cl=shift;'. $sOptionalParams . # generate stack trace for this exception and eliminate duplicate # frames from chained exception; set other variables 'my $st=Exception::Lite::_cacheStackTrace;'. 'if ($e) {my $n=$#{$e->[2]}-$#$st;$e->[2]=[@{$e->[2]}[0..$n]]}'. 'my ($f,$l) = @{$st->[0]};' . # use the caller file/line number to warn of bad parameters 'if (scalar(@_)%2) { shift @_;'. 'warn sprintf($Exception::Lite::MSG_BAD_NEW_PARAMS,$cl,$f,$l'. ',"'.$sAddOrOmit.'");'. '}'. # initialize exception object 'my $h={@_};'.$sMakeMsg. 'my $self=bless([$msg,$h,$st,$$,threads->tid,$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 ($p,$f,$l)=caller(0);$_[0]->PROPAGATE($f,$l);'. 'my $self=shift;' . $sRethrowMsg . 'if (@_%2) { shift @_;' . 'warn sprintf($Exception::Lite::MSG_BAD_RETHROW_PARAMS'. ',$f, $l, "'.$sAddOrOmit.'");' . '} $self->replaceProperties({@_}) if (@_);'. 'return $self'. '}'; unless ($sSuperClass && $sSuperClass->can('_getInterface') && ($sSuperClass->_getInterface() eq __PACKAGE__)) { $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=~s/(sub |use )/\n$1/g; print STDERR "\n$sDeclare\n"; eval $sDeclare; if ($sSuperClass) { # this needs to be in a separate eval, at least in Perl 5.8.8 # Otherwise, for some reason our @ISA ends up being undefined eval "\@${sClass}::ISA=qw($sSuperClass);"; } return $sClass; } #------------------------------------------------------------------ sub isChainable { return ref($_[0])?1:0; } #------------------------------------------------------------------ sub isException { my ($e, $sClass) = @_; my $sRef=ref($e); return !$sRef ? 0 : (defined($sClass) ? $sRef->isa($sClass) : ($sRef->can('_getInterface') && ($e->_getInterface() eq __PACKAGE__)) )? 1 : 0; } #================================================================== # PRIVATE SUBROUTINES #================================================================== # 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 _cacheCall { my $iFrame = $_[0]; my @aCaller; my $sArgs; # caller populates @DB::args if called within DB package eval { package DB; #get rid of eval and call to _cacheCall @aCaller = caller($iFrame+2); # mark leading undefined elements as maybe shifted away my $iDefined; $sArgs = join("\n", map { defined($_) ? do {$iDefined=1; "'$_'"} : 'undef' . (defined($iDefined) ?'':' (maybe shifted away?)' ) } @DB::args); }; return $#aCaller < 0 ? $sArgs : [ @aCaller[0..3], $sArgs ]; } #------------------------------------------------------------------ sub _cacheStackTrace { my @aStack; # set up initial frame my $iFrame=1; # call to new my $xCall = _cacheCall($iFrame++); my ($sPackage, $iFile, $iLine) = @$xCall; $xCall = _cacheCall($iFrame++); #context of call to new while (ref($xCall)) { my $sSub = $xCall->[3]; # subroutine containing file,line my $sArgs = $xCall->[4]; # args used to call $sSub # 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 || ((ref($FILTER) eq 'CODE') && $FILTER->($iFrame, $iFile, $iLine, $sSub, $sArgs)) || ($sSub ne '(eval)')) { push @aStack, [ $iFile, $iLine, $sSub, $sArgs ]; ($sPackage, $iFile, $iLine) = @$xCall; } $xCall = _cacheCall($iFrame++); } push @aStack, [ $iFile, $iLine, "<package: $sPackage>", $xCall ]; return \@aStack; } #------------------------------------------------------------------ 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); $sIndent.=' ' x $TAB; 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,$sArgs) = @{$st->[$iFrame]}; if ($iFrame) { #2nd and following stack frame $sMsg .= "\n${sIndent}${sReach}via file $f, line $l in $s"; } else { # first stack frame $sMsg .= "\n${sIndent}${sThrow}at file $f, line $l in $s, pid=" . $e->getPid() . ", tid=" . $e->getTid(); return "$sMsg\n" if $STRINGIFY == 1; } if ($STRINGIFY > 3) { my $sVar= (($iFrame+1) == $iTop ? '@ARGV' : '@_'); my $sVarIndent = "\n${sIndent}" . (' ' x $TAB); my $sArgPrefix = "${sVarIndent}".(' ' x length($sVar)).' '; $sArgs =~ s/\n/$sArgPrefix,/g; $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; } #================================================================== # MODULE INITIALIZATION #================================================================== 1;

And some excerpts from the pod with a synopsis and a discussion of subclassing and localization.

=head1 NAME B<Exception::Lite> - light weight thread aware, chainable, OOP backed exception strings with integrated message and properties and an uncluttered developer controlled stack trace. =head1 SYNOPSIS # -------------------------------------------------------- # making this module available to your code # -------------------------------------------------------- #Note: there are NO automatic exports use Exception::Lite qw(declareExceptionClass isException isChainable); # -------------------------------------------------------- # declare an exception class # -------------------------------------------------------- #no format rule declareExceptionClass($sClass); declareExceptionClass($sClass, $sSuperClass); declareExceptionClass($sClass, $sSuperClass,$bCustom); #with format rule declareExceptionClass($sClass, $aFormatRule); declareExceptionClass($sClass, $sSuperClass, $aFormatRule); declareExceptionClass($sClass, $sSuperClass, $aFormatRule, $bCustom +); # -------------------------------------------------------- # create an exception but do not throw it # -------------------------------------------------------- # Note: parameters to new depend whether or not there is a format # rule. See documentation for declareExceptionClass. $e = $sClass->new($sMsg, $prop1 => $val1, ...); #no format rule $e = $sClass->new($prop1 => $val1, ...); #has format rule # -------------------------------------------------------- # throw an exception # -------------------------------------------------------- die $sClass->new($sMsg, $prop1 => $val1, ...); #no format rule die $sClass->new($prop1 => $val1, ...); #has format rule # -------------------------------------------------------- # catching an exception reliably (see below for discussion) # -------------------------------------------------------- eval { .... some code that may die here ... return 1; } or do { my $e=$@; .... handle exception using $e, NOT $@ here ... }; # checking the type of an arbitrary caught exception isChainable($e); # can $e be used as a chained exception? isException($e); # does $e have the above exception methods? isException($e,$sClass) # does $e belong to $sClass or a subclass? # -------------------------------------------------------- # exception methods # -------------------------------------------------------- $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 my $e=$@; # $@ is fragile - see Try::Tiny die $e->rethrow(); $@=$e; die; # same as die $e->rethrow() # 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) # -------------------------------------------------------- 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)' =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)]); # in your user interface application. if (isException($e, 'CopyError') && isLocale('fr_FR')) { my $sFrom = $e->getProperty('from'); my $sTo = $e->getProperty('to'); warn sprintf('On ne peut pas copier de %s a %s', $sFrom,$sTo); } =head2 Subclassing Semantics To declare a subclass with custom data and methods, use a three step process: * choose an exception superclass. * call C<declareExceptionClss> with its C<$bCustom> set to 1 * define a _new(...) method and subclass specific methods in a package block. The choice of superclass follows the rule, "like gives birth to like". Exception superclasses that have formats must have a superclass that also takes a format. Exception subclasses that have no format, must use an exception. When the C<$bCustom> flag is set to true, it might be best to think of C<declareExceptionClass> as something like C<use base> or C<use parent> except that there is no implicit BEGIN block. Like both these methods it handles all of the setup details for the class so that you can focus on defining methods and functionality. Wnen C<Exception::Lite> sees the C<$bCustom> flag set to true, it assumes you plan on customizing the class. It will set up inhertance, and generate all the usual method definition for an C<Exception::Lite> class. However, on account of C<$bCustom> being true, it will add a few extra things so that and your custom code can play nicely together: * a special hash reserved for your subclsses data. You can get access to this hash by calling C<_p_getSubclassData()>. * at the end of its C<new()> method, it calls C<< $sClass->_new($self) >>. C<_new()> is a method that your subclass defines. It is responsible for doing additional setup of exception data. * it also ensures that the methods are defined so that you can override any standard object exception method. For example, suppose we want to define a subclass that accepts formats: #define a superclass that accepts formats declareExceptionClass('AnyError' , ['Unexpected exception: %s','exception']); # declare Exception subclass declareExceptionClass('TimedException', 'AnyError', $aFormatData,1); { package TimedException; sub _new { my $self = $_[0]; #exception object created by Exception::Lite # do additional setup of properties here my $timestamp=time(); my $hMyData = $self->_p_getSubclassData(); $hMyData->{when} = time(); } sub getWhen { my $self=$_[0]; return $self->_p_getSubclassData()->{when}; } } Now suppose we wish to extend our custom class further. There is no difference in the way we do things just because it is a subclass of a customized C<Exception::Lite> class: # extend TimedException further so that it # # - adds two additional bits of data - the effective gid and uid # at the time the exception was thrown # - overrides getMessage() to include the time, egid, and euid declareExceptionClass('SecureException', 'TimedException' , $aFormatData,1); { package TimedException; sub _new { my $self = $_[0]; #exception object created by Exception::Lite # do additional setup of properties here my $timestamp=time(); my $hMyData = $self->_p_getSubclassData(); $hMyData->{euid} = $>; $hMyData->{egid} = $); } sub getEuid { my $self=$_[0]; return $self->_p_getSubclassData()->{euid}; } sub getEgid { my $self=$_[0]; return $self->_p_getSubclassData()->{egid}; } sub getMessage { my $self=$_[0]; my $sMsg = $self->SUPER::getMessage(); return sprintf("%s at %s, euid=%s, guid=%s", $sMsg , $self->getWhen(), $self->getEuid(), $self->getGuid()); } }

And, of course, a test suite, because what module doesn't have one?

use strict; use warnings; #use Test::More qw(no_plan); use Test::More tests => 130; use Carp; use Scalar::Util; #--------------------------------------------------------------- BEGIN { use_ok('Exception::Lite', qw(declareExceptionClass)) or BAIL_OUT; }; my $TEST_CLASS='Exception::Lite'; #================================================================== # TEST SUITES #================================================================== sub testNew { my ($sClass, $sSuperclass, $sMsg, $hProperties, $xStringify) = @_; # verify that we can make the class is(declareExceptionClass($sClass, $sSuperclass), $sClass , "declareExceptionClass($sClass)"); # verify that we get the right type of exception my $e = $sClass->new($sMsg, %$hProperties); my $iLine = __LINE__; is(ref($e), $sClass, "the new object belongs to class $sClass"); if ($sSuperclass) { is($e->isa($sSuperclass)?1:0,1, "->isa($sSuperclass)"); } # verify that our exception acts like a string in string context testStringify("new $sClass object", $e, $sMsg, 0); testStringify("new $sClass object", $e, $sMsg, 1); testStringify("new $sClass object", $e, $sMsg , sub { "***$_[0]***" }); testStringify("new $sClass object", $e, $sMsg, \&carp, 1); # test numeric conversion - eval because there will be a fatal # exception if it can't find the proper operators eval { my $eCopy=$sClass->new($sMsg, %$hProperties); is($e+0, Scalar::Util::refaddr($e) , "\$e+0 is equal to its refaddr"); ok($e == $e, "Exception == exception works"); ok($e != $eCopy, "Exception != exception works"); ok($e eq $eCopy, "eq and == have different results"); return 1; } or do { my $e=$@; diag("Warning! $e"); }; # test methods other than getProperties is(ref($e), $sClass, "the new object belongs to class $sClass"); testMethods($e, $sMsg, $hProperties, $iLine, undef); # test dying eval { die $sClass->new("Junk"); } or do { my $e=$@; is( (ref($e) && $e->isa($sClass))?1:0, 1 , "caught a thrown instance of the class"); testStringify("caught exception:", $e, 'Junk', 0); }; # chained exception my $e2 = $sClass->new($e); $iLine = __LINE__; testMethods($e2, $sMsg, {}, $iLine, $e); # chained exception with its own message and properties my $k = 'nanana'; my $v = 'yayaya'; my $sNewMsg = "***$sMsg***"; my $e3 = $sClass->new($e, $sNewMsg, $k => $v); $iLine = __LINE__; testMethods($e3, $sNewMsg, { $k => $v }, $iLine, $e); # test propagation using $@=$e; die; eval { eval { eval { $iLine = __LINE__; die $sClass->new('Dying...'); } or do { my $e=$@; my $aPropagation = $e->getPropagation(); is(scalar(@$aPropagation), 0, "$sClass: ->getPropagation() == +0"); $iLine = __LINE__; $@=$e; die; }; } or do { my $e=$@; my $aPropagation = $e->getPropagation(); is(scalar(@$aPropagation), 1, "$sClass: ->getPropagation() == 1" +); is($aPropagation->[0]->[0], __FILE__ , "$sClass: ->getPropagation()->[0]->[0]"); is($aPropagation->[0]->[1],$iLine , "$sClass: ->getPropagation()->[0]->[1]"); $iLine = __LINE__; $@=$e; die; }; } or do { my $e=$@; my $aPropagation = $e->getPropagation(); is(scalar(@$aPropagation), 2, "$sClass: ->getPropagation() == 1"); is($aPropagation->[1]->[0], __FILE__ , "$sClass: ->getPropagation()->[1]->[0]"); is($aPropagation->[1]->[1],$iLine , "$sClass: ->getPropagation()->[1]->[1]"); }; # test propagation using die $e->rethrow(); eval { eval { eval { $iLine = __LINE__; die $sClass->new('Dying...'); } or do { my $e=$@; my $aPropagation = $e->getPropagation(); is(scalar(@$aPropagation), 0, "$sClass: ->getPropagation() == +0"); $iLine = __LINE__; die $e->rethrow(undef, a => "aaa"); }; } or do { my $e=$@; my $aPropagation = $e->getPropagation(); is(scalar(@$aPropagation), 1, "$sClass: ->getPropagation() == 1" +); is($aPropagation->[0]->[1],$iLine , "$sClass: ->getPropagation()->[0]->[1]"); is($e->getProperty('a'), 'aaa' , "$sClass:->getProperty(a) returns value set on rethrow #1") +; $iLine = __LINE__; die $e->rethrow(undef, a => "bbb"); }; } or do { my $e=$@; my $aPropagation = $e->getPropagation(); is(scalar(@$aPropagation), 2, "$sClass: ->getPropagation() == 1"); is($aPropagation->[1]->[1],$iLine , "$sClass: ->getPropagation()->[1]->[1]"); is($e->getProperty('a'), 'bbb' , "$sClass:->getProperty(a) returns value set on rethrow #2"); }; } #--------------------------------------------------------------- sub testClassFormat { my ($sClass, $aMakeMsg, $aTestSuite) = @_; my $sContext = "$sClass(@$aMakeMsg)"; my $ePrevious; my $iChainedTests=0; declareExceptionClass($sClass, undef, $aMakeMsg); foreach my $aTest (@$aTestSuite) { my ($sMsg, $hProperties, $bChained) = @$aTest; my $e; if ($bChained) { $e = $sClass->new($ePrevious, %$hProperties); is($e->getChained, $ePrevious, "$sContext: ->getChained()"); $iChainedTests++; } else { $e = $sClass->new(%$hProperties); is($e->getChained, undef, "$sContext: ->getChained()"); } is($e->getMessage, $sMsg, "$sContext: ->getMessage()"); $ePrevious=$e; } if (!$iChainedTests) { diag("Warning: no chained tests for $sContext"); } } #--------------------------------------------------------------- sub testCustomizedClass { my ($sClass, $sSuperClass)=@_; my $sContext = "testCustomizedClass: $sClass"; my $aFormat = ['%s likes %s', qw(name food)]; declareExceptionClass($sClass, $sSuperClass, $aFormat,1); ok($sClass->can('_p_getSubclassData') , "$sContext: _p_getSubclassData is defined"); is($sClass->can('getMessage'), $sSuperClass->can('getMessage') , "$sContext: getMessage() is inherited and may be overridden"); my $sCustom = "{ package $sClass;" .'sub _new {$_[0]->_p_getSubclassData()->{when}=time()}' .'sub getWhen {$_[0]->_p_getSubclassData()->{when}}' .'sub getMessage { ' .'$_[0]->SUPER::getMessage() . " when=". $_[0]->getWhen() }' .'}'; eval $sCustom; ok($sClass->can('getMessage') != $sSuperClass->can('getMessage') , "$sContext: getMessage() is no longer inherited after custom " ."methods are defined"); my $e=$sClass->new(name=>'Joe', food=>'peanutbutter'); like($e->getMessage(), qr{\w+ likes \w+ when=\d+$}); } #--------------------------------------------------------------- sub testObjectFormat { my ($sClass, $aMakeMsg, $aTestSuite) = @_; my $sContext = "$sClass(@$aMakeMsg[1..$#$aMakeMsg])"; declareExceptionClass($sClass, undef, $aMakeMsg); foreach my $aTest (@$aTestSuite) { my ($sMsg, $sFormat, $hProperties) = @$aTest; my $e = $sClass->new($sFormat, %$hProperties); is($e->getMessage, $sMsg, "$sContext: ->getMessage()"); } } #--------------------------------------------------------------- sub testStringify { my ($sContext, $e, $sMsg, $xStringify, $bTrapWarning) = @_; $Exception::Lite::STRINGIFY=$xStringify; my $sStringify; if ($bTrapWarning) { eval { my $sWarning; $SIG{__WARN__}= sub { $sWarning=$_[0]; }; do {return "$e"}; like($sWarning, qr/\Q$sMsg\E/ , $sContext . ': "$e" - checking warning'); do {return "".$e}; like($sWarning, qr/\Q$sMsg\E/ , $sContext . ': "".$e - checking warning'); do {return "x:".$e}; like($sWarning, qr/\Q$sMsg\E/ , $sContext . ': "x:".$e - checking warning'); do {return $e eq 0}; like($sWarning, qr/\Q$sMsg\E/ , $sContext . ': $e eq ... - checking warning'); }; } else { $sStringify= !$xStringify ? $sMsg : ref($xStringify) eq 'CODE' ? $xStringify->($sMsg) : Exception::Lite::_dumpMessage($e); is("$e", $sStringify, $sContext . ': "$e"' ); is("".$e, $sStringify, $sContext . ': "".$e'); is("x:".$e, "x:".$sStringify, $sContext . ': "x:".$e'); is($e, $sStringify, $sContext . ': $e eq ...'); } } #================================================================== # SUBTESTS #================================================================== #--------------------------------------------------------------- sub testMethods { my ($e, $sMsg, $hProperties, $iLine, $eChained) = @_; # test location of throw is($e->getPackage(), __PACKAGE__, "->getPackage()"); is($e->getFile(), __FILE__, "->getFile()"); is($e->getLine(), $iLine, "->getLine()"); is($e->getSubroutine(), 'main::testNew', "->getSubroutine()"); is($e->getChained(), $eChained, "->getChained()"); # test message is($e->getMessage(), $sMsg, "->getMessage()"); # test properties while (my ($k,$v) = each (%$hProperties)) { is($e->getProperty($k), $v, "->getProperty($k)"); } } #================================================================== # EXCEPTION DEMO #================================================================== # ----------------------------------------- # Setup # ----------------------------------------- use threads; declareExceptionClass('Foo'); sub notAWhatButAWho { my @aDummy=(3); weKnowBetterThanYou (\@aDummy , '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 Wikerson 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 tiny Yopp! of the ' . 'smallest of all' ); push @aDummy, 2; } sub weKnowBetterThanYou { my $aDummies = shift; my $iCountDummies=scalar @$aDummies; my $sWords = $_[0]; eval { hoo('Dr Hoovey','hoo-hoo scope','Mrs Tucanella','Uncle Nate'); return 1; } or do { my $e=$@; die Foo->new($e,'Mayhem! and then ...'); } } sub hoo { eval { horton('15th of May', 'Jungle of Nool' , 'a small speck of dust on a small clover' , 'a person\'s a person no matter how small' ); return 1; } or do { die; } } sub horton { die Foo->new("Horton hears a hoo!"); } # ----------------------------------------- # Run demo # ----------------------------------------- sub runDemo { diag("\n"); # put new line at end of test counter line my $t; $t=threads->new(sub { diag("\n---------------------------------------------------\n" . "Sample exception STRINGIFY=4 running on thread " . threads->tid . "\n---------------------------------------------------\n" ); $Exception::Lite::STRINGIFY=4; eval { notAWhatButAWho() } or do {my $e=$@; diag("$e"); }; }); $t->join(); $t = threads->new(sub { diag("\n---------------------------------------------------\n" . "Sample exception STRINGIFY=3 running on thread " . threads->tid . "\nFILTER=OFF" . "\n---------------------------------------------------\n" ); my $iSave=$Exception::Lite::FILTER_TRACE; $Exception::Lite::FILTER_TRACE=0; $Exception::Lite::STRINGIFY=3; eval { notAWhatButAWho() } or do {my $e=$@; diag("$e"); }; $Exception::Lite::FILTER_TRACE=$iSave; }); $t->join(); $t = threads->new(sub { diag("\n---------------------------------------------------\n" . "Sample exception STRINGIFY=3 running on thread " . threads->tid . "\nFILTER=ON" . "\n---------------------------------------------------\n" ); $Exception::Lite::STRINGIFY=3; eval { notAWhatButAWho() } or do {my $e=$@; diag("$e"); }; }); $t->join(); $t = threads->new(sub { diag("\n---------------------------------------------------\n" . "Sample exception STRINGIFY=2 running on thread " . threads->tid . "\n---------------------------------------------------\n" ); $Exception::Lite::STRINGIFY=2; eval { notAWhatButAWho() } or do {my $e=$@; diag("$e"); }; }); $t->join(); $t = threads->new(sub { diag("\n---------------------------------------------------\n" . "Sample exception STRINGIFY=1 running on thread " . threads->tid . "\n---------------------------------------------------\n" ); $Exception::Lite::STRINGIFY=1; eval { notAWhatButAWho() } or do {my $e=$@; diag("$e"); }; }); $t->join(); $t = threads->new(sub { diag("\n---------------------------------------------------\n" . "Sample exception STRINGIFY=0 running on thread " . threads->tid . "\n---------------------------------------------------\n" ); $Exception::Lite::STRINGIFY=0; eval { notAWhatButAWho() } or do {my $e=$@; diag("$e"); }; }); $t->join(); # mark end of demo diag("\n----------------------------\n" ."End of demo. Goodbye!" ."\n----------------------------\n" ); } #================================================================== # TEST PLAN #================================================================== testNew('X', undef, 'Hello World' , { name => 'danny', location => 'israel' }); testNew('A', 'X', 'Morning has broken'); testClassFormat('Z', [ '%s, %s!', qw(greeting name)] , [[ 'Hello, World!', {greeting=>'Hello',name=>'World'}] ,[ 'Boker tov, Ayala!', {greeting=>'Boker tov', name=>'Ayala'} ] ,[ 'Boker tov, <undef>!', {greeting=>'Boker tov'} ] ,[ '<undef>, Ayala!', {name => 'Ayala'}, 1 ] ]); testCustomizedClass('Preferences::A::B::C','Z'); #runDemo();

One interesting detail: it takes about 3x as many lines of code to generate the exception as is in the actual exception itself.

Hmmm.

Update: Just noticed a "print STDERR" that I meant to comment out and didn't - so now it are commented out. The line displays the code for the generated class. If you want to inspect the generated class, you can re-uncomment it.

.

In reply to Re^2: RFC: A better name for an exception handling module? by ELISHEVA
in thread RFC: A better name for an exception handling module? by ELISHEVA

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others chanting in the Monastery: (6)
As of 2024-03-29 09:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found