File Coverage

blib/lib/Exception/Lite.pm
Criterion Covered Total %
statement 296 436 67.8
branch 86 200 43.0
condition 8 24 33.3
subroutine 57 110 51.8
pod 1 82 1.2
total 448 852 52.5


line stmt bran cond sub pod time code
1             # Copyright (c) 2010 Elizabeth Grace Frank-Backman.
2             # All rights reserved.
3             # Liscenced under the "Artistic Liscence"
4             # (see http://dev.perl.org/licenses/artistic.html)
5              
6 1     1   33349 use 5.8.8;
  1         4  
  1         45  
7 1     1   6 use strict;
  1         2  
  1         34  
8 1     1   5 use warnings;
  1         6  
  1         36  
9 1     1   1956 use overload;
  1         1171  
  1         5  
10              
11             package Exception::Lite;
12             our @ISA = qw(Exporter);
13             our @EXPORT_OK=qw(declareExceptionClass isException isChainable
14             onDie onWarn);
15             our %EXPORT_TAGS
16             =( common => [qw(declareExceptionClass isException isChainable)]
17             , all => [@EXPORT_OK]
18             );
19             my $CLASS='Exception::Lite';
20              
21             #------------------------------------------------------------------
22              
23             our $STRINGIFY=3;
24             our $FILTER=1;
25             our $UNDEF='';
26             our $TAB=3;
27             our $LINE_LENGTH=120;
28              
29             # provide command line control over amount and layout of debugging
30             # information, e.g. perl -mException::Lite=STRINGIFY=4
31              
32             sub import {
33             Exception::Lite->export_to_level(1, grep {
34 1 50   1   11 if (/^(\w+)=(.*)$/) {
  2         6  
35 0         0 my $k = $1;
36 0         0 my $v = $2;
37 0 0       0 if ($k eq 'STRINGIFY') { $STRINGIFY=$v;
  0 0       0  
    0          
    0          
38 0         0 } elsif ($k eq 'FILTER') { $FILTER=$v;
39 0         0 } elsif ($k eq 'LINE_LENGTH') { $LINE_LENGTH=$v;
40 0         0 } elsif ($k eq 'TAB') { $TAB=$v;
41             }
42 0         0 0;
43             } else {
44 2         175 1;
45             }
46             } @_);
47             }
48              
49             #------------------------------------------------------------------
50             # Note to source code divers: DO NOT USE THIS. This is intended for
51             # internal use but must be declared with "our" because we need to
52             # localize it. This is an implementation detail and cannot be relied
53             # on for future releases.
54              
55             our $STACK_OFFSET=0;
56              
57             #------------------------------------------------------------------
58              
59 1     1   388 use Scalar::Util ();
  1         2  
  1         20  
60 1     1   5 use constant EVAL => '(eval)';
  1         3  
  1         3936  
61              
62             #==================================================================
63             # EXPORTABLE FUNCTIONS
64             #==================================================================
65              
66             sub declareExceptionClass {
67 7     7 1 935 my ($sClass, $sSuperClass, $xFormatRule, $bCustomizeSubclass) = @_;
68 7         14 my $sPath = $sClass; $sPath =~ s/::/\//g; $sPath .= '.pm';
  7         30  
  7         12  
69 7 100       35 if ($INC{$sPath}) {
70             # we want to start with the caller's frame, not ours
71 1         3 local $STACK_OFFSET = $STACK_OFFSET + 1;
72 1         46 die 'Exception::Lite::Any'->new("declareExceptionClass failed: "
73             . "$sClass is already defined!");
74 0         0 return undef;
75             }
76              
77 6         13 my $sRef=ref($sSuperClass);
78 6 100       15 if ($sRef) {
79 1         2 $bCustomizeSubclass = $xFormatRule;
80 1         2 $xFormatRule = $sSuperClass;
81 1         3 $sSuperClass=undef;
82             } else {
83 5         11 $sRef = ref($xFormatRule);
84 5 50 66     29 if (!$sRef && defined($xFormatRule)) {
85 0         0 $bCustomizeSubclass = $xFormatRule;
86 0         0 $xFormatRule = undef;
87             }
88             }
89              
90             # set up things dependent on whether or not the class has a
91             # format string or expects a message for each instance
92              
93 6         8 my ($sLeadingParams, $sAddOrOmit, $sRethrowMsg, $sMakeMsg);
94 6         20 my $sReplaceMsg='';
95              
96 6 100       14 if ($sRef) {
97 3         8 $sLeadingParams='my $e; $e=shift if ref($_[0]);';
98 3         5 $sAddOrOmit='added an unnecessary message or format';
99 3         7 $sRethrowMsg='';
100              
101             #generate format rule
102 3 50       10 $xFormatRule=$xFormatRule->($sClass) if ($sRef eq 'CODE');
103              
104 3         10 my $sFormat= 'q{' . $xFormatRule->[0] . '}';
105 3 50       11 if (scalar($xFormatRule) == 1) {
106 0         0 $sMakeMsg='my $msg='.$sFormat;
107             } else {
108 3         22 my $sSprintf = 'Exception::Lite::_sprintf(' . $sFormat
109             . ', map {defined($_)?$_:\''. $UNDEF .'\'} @$h{qw('
110             . join(' ', @$xFormatRule[1..$#$xFormatRule]) . ')});';
111 3         6 $sMakeMsg='my $msg='.$sSprintf;
112 3         8 $sReplaceMsg='$_[0]->[0]='.$sSprintf;
113             }
114              
115             } else {
116 3         7 $sLeadingParams = 'my $e=shift; my $msg;'.
117             'if(ref($e)) { $msg=shift; $msg=$e->[0] if !defined($msg);}'.
118             'else { $msg=$e;$e=undef; }';
119 3         6 $sAddOrOmit='omitted a required message';
120 3         5 $sRethrowMsg='my $msg=shift; $_[0]->[0]=$msg if defined($msg);';
121 3         4 $sMakeMsg='';
122             }
123              
124             # put this in an eval so that it doesn't cause parse errors at
125             # compile time in no-threads versions of Perl
126              
127 6         482 my $sTid = eval q{defined(&threads::tid)?'threads->tid':'undef'};
128              
129 6         47 my $sDeclare = "package $sClass;".
130             'sub new { my $cl=shift;'. $sLeadingParams .
131             'my $st=Exception::Lite::_cacheStackTrace($e);'.
132             'my $h= Exception::Lite::_shiftProperties($cl' .
133             ',$st,"'.$sAddOrOmit.'",@_);' . $sMakeMsg .
134             'my $self=bless([$msg,$h,$st,$$,'.$sTid.',$e,[]],$cl);';
135              
136             # the remainder depends on the type of subclassing
137              
138 6 100       14 if ($bCustomizeSubclass) {
139 1         3 $sDeclare .= '$self->[7]={}; $self->_new(); return $self; }'
140             . 'sub _p_getSubclassData { $_[0]->[7]; }';
141             } else {
142 5         24 $sDeclare .= 'return $self;}'.
143             'sub replaceProperties {'.
144             'my $h={%{$_[0]->[1]},%{$_[1]}}; $_[0]->[1]=$h;'.$sReplaceMsg.
145             '}'.
146             'sub rethrow {' .
147             'my $self=shift;' . $sRethrowMsg .
148             'Exception::Lite::_rethrow($self,"'.$sAddOrOmit.'",@_)' .
149             '}';
150              
151 5 100       16 unless (isExceptionClass($sSuperClass)) {
152 4         9 $sDeclare .=
153             'sub _getInterface { \'Exception::Lite\' }' .
154             'sub getMessage { $_[0]->[0] };' .
155             'sub getProperty { $_[0]->[1]->{$_[1]} }' .
156             'sub isProperty { exists($_[0]->[1]->{$_[1]})?1:0 }' .
157             'sub getStackTrace { $_[0]->[2] }' .
158             'sub getFrameCount { scalar(@{$_[0]->[2]}); }' .
159             'sub getFile { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[0] };' .
160             'sub getLine { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[1] };' .
161             'sub getSubroutine { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[2] };' .
162             'sub getArgs { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[3] };' .
163             'sub getPackage {$_[0]->[2]->[-1]->[2] =~ /(\w+)>$/;$1}'.
164             'sub getPid { $_[0]->[3] }' .
165             'sub getTid { $_[0]->[4] }' .
166             'sub getChained { $_[0]->[5] }' .
167             'sub getPropagation { $_[0]->[6]; }' .
168             'use overload '.
169             'q{""} => \&Exception::Lite::_dumpMessage ' .
170             ', q{0+} => \&Exception::Lite::_refaddr, fallback=>1;' .
171             'sub PROPAGATE { push @{$_[0]->[6]},[$_[1],$_[2]]; $_[0]}';
172             }
173             }
174 6         13 $sDeclare .= 'return 1;';
175              
176             local $SIG{__WARN__} = sub {
177 0     0   0 my ($p,$f,$l) = caller(2);
178 0         0 my $s=$_[0]; $s =~ s/at \(eval \d+\)\s+line\s+\d+\.//m;
  0         0  
179 0         0 print STDERR "$s in declareExceptionClass($sClass,...) "
180             ."in file $f, line $l\n";
181 6         59 };
182              
183 1 50   1 0 6 eval $sDeclare or do {
  1 0   1 0 2  
  1 0   1 0 6  
  1 0   1 0 8  
  1 0   0 0 2  
  1 0   8 0 29  
  1 50   0 0 10  
  1 0   0 0 1  
  1 0   0 0 11  
  1 0   0 0 9  
  1 0   0 0 1  
  1 0   1 0 8  
  6 50   2 0 4249  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  8 50   0 0 7377  
  8 0   18 0 35  
  8 0   0 0 36  
  0 0   1 0 0  
  0 0   7 0 0  
  0 0   0 0 0  
  0 50   6 0 0  
  0 50   0 0 0  
  0 100   0 0 0  
  0 100   0 0 0  
  0 100   0 0 0  
  0 100   0 0 0  
  1 100   0 0 7  
  2 100   0 0 78  
  0 100   0 0 0  
  0 50   0 0 0  
  0 50   6 0 0  
  0 0   8 0 0  
  18 0   62 0 65  
  0 50   0 0 0  
  1 0   1 0 4  
  7 50   0 0 241  
  0     0 0 0  
  6     0 0 44  
  0     6 0 0  
  0     22 0 0  
  0     3 0 0  
  0     1 0 0  
  0     0 0 0  
  0     3 0 0  
  0     1 0 0  
  0     0 0 0  
  0     24 0 0  
  0     0 0 0  
  0     8 0 0  
  0     0 0 0  
  0     0 0 0  
  6     26 0 38  
  8     0 0 1009  
  62     1 0 203  
  0     3 0 0  
  1     0 0 5  
  0     0 0 0  
  0     0 0 0  
  0     6 0 0  
  0     1 0 0  
  0     22 0 0  
  0     0 0 0  
  6     3 0 170  
  6     0 0 32  
  22     0 0 105  
  3     0 0 16  
  1     0 0 6  
  0     1 0 0  
  3     2 0 10  
  1     4 0 5  
  0     7 0 0  
  24     7 0 500  
  0     1 0 0  
  8     0 0 4614  
  0     2   0  
  0     0   0  
  26     2   69  
  0     0   0  
  1     2   6  
  3     0   8  
  0     0   0  
  0     2   0  
  0     0   0  
  6         45  
  1         5  
  22         57  
  0         0  
  3         10  
  0         0  
  0         0  
  0         0  
  0         0  
  1         3  
  1         2  
  1         3  
  1         8  
  0         0  
  0         0  
  1         2  
  1         2  
  1         4  
  1         6  
  1         9  
  1         9  
  2         5  
  2         3  
  2         6  
  2         8  
  2         8  
  2         6  
  2         12  
  2         10  
  2         18  
  4         42  
  4         7  
  4         12  
  4         13  
  4         14  
  4         12  
  8         30  
  4         20  
  4         13  
  7         4261  
  7         11  
  7         10  
  7         17  
  2         5  
  2         9  
  5         7  
  5         6  
  7         27  
  7         29  
  7         39  
  7         30  
  7         9476  
  7         15  
  7         8  
  7         24  
  2         5  
  2         11  
  5         8  
  5         10  
  7         29  
  7         30  
  7         38  
  7         31  
  1         5136  
  1         3  
  1         7  
  1         7  
  1         7  
  1         5  
  2         11  
  1         8  
  1         59  
  1         21  
  1         4  
  0         0  
  0         0  
  0         0  
  0         0  
  2         4  
  2         6  
  2         10  
  2         9  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  2         4  
  2         6  
  2         10  
  2         8  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  2         914  
  2         4  
  2         7  
  2         9  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  2         1678  
  2         4  
  2         7  
  2         9  
  0         0  
  0         0  
184 0         0 my ($p,$f,$l) = caller(1);
185 0         0 print STDERR "Can't create class $sClass at file $f, line $l\n";
186 0 0       0 if ($sClass =~ /\w:\w/) {
    0          
187 0         0 print STDERR "Bad class name: "
188             ."At least one ':' is not doubled\n";
189             } elsif ($sClass !~ /^\w+(?:::\w+)*$/) {
190 0         0 print STDERR "Bad class name: $sClass\n";
191             } else {
192 0         0 $sDeclare=~s/(sub |use )/\n$1/g; print STDERR "$sDeclare\n";
  0         0  
193             }
194             };
195              
196             # this needs to be separate from the eval, otherwise it never
197             # ends up in @INC or @ISA, at least in Perl 5.8.8
198 6         23 $INC{$sPath} = __FILE__;
199 6 100       152 eval "\@${sClass}::ISA=qw($sSuperClass);" if $sSuperClass;
200              
201 6         70 return $sClass;
202             }
203              
204             #------------------------------------------------------------------
205              
206 0 0   0 0 0 sub isChainable { return ref($_[0])?1:0; }
207              
208             #------------------------------------------------------------------
209              
210             sub isException {
211 0     0 0 0 my ($e, $sClass) = @_;
212 0         0 my $sRef=ref($e);
213 0 0       0 return !defined($sClass)
    0          
    0          
    0          
    0          
    0          
214             ? ($sRef ? isExceptionClass($sRef) : 0)
215             : $sClass eq ''
216             ? ($sRef eq '' ? 1 : 0)
217             : ($sRef eq '')
218             ? 0
219             : $sRef->isa($sClass)
220             ?1:0;
221             }
222              
223             #------------------------------------------------------------------
224              
225             sub isExceptionClass {
226 5 100 66 5 0 69 return defined($_[0]) && $_[0]->can('_getInterface')
227             && ($_[0]->_getInterface() eq __PACKAGE__) ? 1 : 0;
228             }
229              
230             #------------------------------------------------------------------
231              
232             sub onDie {
233 0     0 0 0 my $iStringify = $_[0];
234             $SIG{__DIE__} = sub {
235 0     0   0 $Exception::Lite::STRINGIFY=$iStringify;
236 0 0 0     0 warn 'Exception::Lite::Any'->new('Unexpected death:'.$_[0])
237             unless $^S || isException($_[0]);
238 0         0 };
239             }
240              
241             #------------------------------------------------------------------
242              
243             sub onWarn {
244 0     0 0 0 my $iStringify = $_[0];
245             $SIG{__WARN__} = sub {
246 0     0   0 $Exception::Lite::STRINGIFY=$iStringify;
247 0         0 print STDERR 'Exception::Lite::Any'->new("Warning: $_[0]");
248 0         0 };
249             }
250              
251             #==================================================================
252             # PRIVATE SUBROUTINES
253             #==================================================================
254              
255             #------------------------------------------------------------------
256              
257             sub _cacheCall {
258 83     83   103 my $iFrame = $_[0];
259              
260 83         90 my @aCaller;
261             my $aArgs;
262              
263             # caller populates @DB::args if called within DB package
264 83         101 eval {
265             # this 2 line wierdness is needed to prevent Module::Build from finding
266             # this and adding it to the provides list.
267             package
268             DB;
269              
270             #get rid of eval and call to _cacheCall
271 83         583 @aCaller = caller($iFrame+2);
272              
273             # mark leading undefined elements as maybe shifted away
274 83         107 my $iDefined;
275 83 100       195 if ($#aCaller < 0) {
276 22         42 @DB::args=@ARGV;
277             }
278 163         180 $aArgs = [ map {
279 83         150 defined($_)
280 170 50       7168 ? do {$iDefined=1;
    100          
281 163 100       716 "'$_'" . (overload::Method($_,'""')
282             ? ' ('.overload::StrVal($_).')':'')}
283             : 'undef' . (defined($iDefined)
284             ? '':' (maybe shifted away?)')
285             } @DB::args];
286             };
287              
288 83 100       1776 return $#aCaller < 0 ? \$aArgs : [ @aCaller[0..3], $aArgs ];
289             }
290              
291             #------------------------------------------------------------------
292              
293             sub _cacheStackTrace {
294 22     22   43 my $e=$_[0]; my $st=[];
  22         37  
295              
296             # set up initial frame
297 22         65 my $iFrame= $STACK_OFFSET + 1; # call to new
298 22         61 my $aCall = _cacheCall($iFrame++);
299 22         63 my ($sPackage, $iFile, $iLine, $sSub, $sArgs) = @$aCall;
300 22         29 my $iLineFrame=$iFrame;
301              
302 22         52 $aCall = _cacheCall($iFrame++); #context of call to new
303 22         89 while (ref($aCall) ne 'REF') {
304 39         62 $sSub = $aCall->[3]; # subroutine containing file,line
305 39         54 $sArgs = $aCall->[4]; # args used to call $sSub
306              
307             #print STDERR "debug-2: package=$sPackage file=$iFile line=$iLine"
308             # ." sub=$sSub, args=@$sArgs\n";
309              
310             # in evals we want the line number within the eval, but the
311             # name of the sub in which the eval was located. To get this
312             # we wait to push on the stack until we get an actual sub name
313             # and we avoid overwriting the location information, hence 'ne'
314              
315 39 100 66     262 if (!$FILTER || ($sSub ne EVAL)) {
316 22         53 my $aFrame=[ $iFile, $iLine, $sSub, $sArgs ];
317 22         64 ($sPackage, $iFile, $iLine) = @$aCall;
318 22         38 $iLineFrame=$iFrame;
319              
320 22         38 my $sRef=ref($FILTER);
321 22 50 33     142 if ($sRef eq 'CODE') {
    50 33        
    50          
322 0         0 my $x = $FILTER->(@$aFrame, $iFrame, $iLineFrame);
323 0 0       0 if (ref($x) eq 'ARRAY') {
    0          
324 0         0 $aFrame=$x;
325             } elsif (!$x) {
326 0         0 $aFrame=undef;
327             }
328             } elsif (($sRef eq 'ARRAY') && ! _isIgnored($sSub, $FILTER)) {
329 0         0 $aFrame=undef;
330             } elsif (($sRef eq 'Regexp') && !_isIgnored($sSub, [$FILTER])) {
331 0         0 $aFrame=undef;
332             }
333 22 50       72 push(@$st, $aFrame) if $aFrame;
334             }
335              
336 39         187 $aCall = _cacheCall($iFrame++);
337             }
338              
339 22         76 push @$st, [ $iFile, $iLine, "", $$aCall ];
340 22 100       322 if ($e) { my $n=$#{$e->[2]}-$#$st;$e->[2]=[@{$e->[2]}[0..$n]]};
  5         8  
  5         59  
  5         19  
  5         13  
341 22         1069 return $st;
342             }
343              
344             #-----------------------------
345              
346             sub _isIgnored {
347 0     0   0 my ($sSub, $aIgnore) = @_;
348 0 0       0 foreach my $re (@$aIgnore) { return 1 if $sSub =~ $re; }
  0         0  
349 0         0 return 0;
350             }
351              
352             #------------------------------------------------------------------
353              
354             sub _dumpMessage {
355 60     60   7604 my ($e, $iDepth) = @_;
356              
357 60         1803 my $sMsg = $e->getMessage();
358 60 100       248 return $sMsg unless $STRINGIFY;
359 40 100       92 if (ref($STRINGIFY) eq 'CODE') {
360 10         415 return $STRINGIFY->($sMsg);
361             }
362              
363 30 50       78 $iDepth = 0 unless defined($iDepth);
364 30         65 my $sIndent = ' ' x ($TAB*$iDepth);
365 30         64 $sMsg = "\n${sIndent}Exception! $sMsg";
366 30 50       64 return $sMsg if $STRINGIFY == 0;
367              
368 30         39 my ($sThrow, $sReach);
369 30         106 my $sTab = ' ' x $TAB;
370              
371 30         38 $sIndent.= $sTab;
372 30 100       68 if ($STRINGIFY > 2) {
373 16         451 my $aPropagation = $e->getPropagation();
374 16         59 for (my $i=$#$aPropagation; $i >= 0; $i--) {
375 0         0 my ($f,$l) = @{$aPropagation->[$i]};
  0         0  
376 0         0 $sMsg .= "\n${sIndent}rethrown at file $f, line $l";
377             }
378 16         22 $sMsg .= "\n";
379 16         23 $sThrow='thrown ';
380 16         27 $sReach='reached ';
381             } else {
382 14         17 $sThrow='';
383 14         22 $sReach='';
384             }
385              
386 30         832 my $st=$e->getStackTrace();
387 30         45 my $iTop = scalar @$st;
388              
389 30         76 for (my $iFrame=0; $iFrame<$iTop; $iFrame++) {
390 30         33 my ($f,$l,$s,$aArgs) = @{$st->[$iFrame]};
  30         76  
391              
392 30 100       59 if ($iFrame) {
393             #2nd and following stack frame
394 4         15 my $sVia="${sIndent}${sReach}via file $f, line $l";
395 4         10 my $sLine="$sVia in $s";
396 4 50       18 $sMsg .= (length($sLine)>$LINE_LENGTH
397             ? "\n$sVia\n$sIndent${sTab}in $s" : "\n$sLine");
398             } else {
399             # first stack frame
400 26         671 my $tid=$e->getTid();
401 26         67 my $sAt="${sIndent}${sThrow}at file $f, line $l";
402 26         51 my $sLine="$sAt in $s";
403 26 50       731 $sMsg .= (length($sLine)>$LINE_LENGTH
    50          
404             ? "\n$sAt\n$sIndent${sTab}in $s" : "\n$sLine")
405             . ", pid=" . $e->getPid() . (defined($tid)?", tid=$tid":'');
406              
407 26 100       175 return "$sMsg\n" if $STRINGIFY == 1;
408             }
409              
410 16 50       60 if ($STRINGIFY > 3) {
411 0         0 my $bTop = ($iFrame+1) == $iTop;
412 0 0 0     0 my $sVar= ($bTop && !$iDepth) ? '@ARGV' : '@_';
413 0   0     0 my $bMaybeEatenByGetOpt = $bTop && !scalar(@$aArgs)
414             && exists($INC{'Getopt/Long.pm'});
415              
416 0         0 my $sVarIndent = "\n${sIndent}" . (' ' x $TAB);
417 0         0 my $sArgPrefix = "${sVarIndent}".(' ' x length($sVar)).' ';
418 0 0       0 if ($bMaybeEatenByGetOpt) {
419 0         0 $sMsg .= $sArgPrefix . $sVar
420             . '() # maybe eaten by Getopt::Long?';
421             } else {
422 0         0 my $sArgs = join($sArgPrefix.',', @$aArgs);
423 0         0 $sMsg .= "${sVarIndent}$sVar=($sArgs";
424 0 0       0 $sMsg .= $sArgs ? "$sArgPrefix)" : ')';
425             }
426             }
427             }
428 16         26 $sMsg.="\n";
429 16 50       33 return $sMsg if $STRINGIFY == 2;
430              
431 16         449 my $eChained = $e->getChained();
432 16 50       42 if (defined($eChained)) {
433 0 0       0 my $sTrigger = isException($eChained)
434             ? _dumpMessage($eChained, $iDepth+1)
435             : "\n${sIndent}$eChained\n";
436 0         0 $sMsg .= "\n${sIndent}Triggered by...$sTrigger";
437             }
438 16         175 return $sMsg;
439             }
440              
441             #------------------------------------------------------------------
442              
443             # refaddr has a prototype($) so we can't use it directly as an
444             # overload operator: it complains about being passed 3 parameters
445             # instead of 1.
446 20     20   188 sub _refaddr { Scalar::Util::refaddr($_[0]) };
447              
448             #------------------------------------------------------------------
449              
450             sub _rethrow {
451 4     4   9 my $self = shift; my $sAddOrOmit = shift;
  4         6  
452 4         27 my ($p,$f,$l)=caller(1);
453 4         121 $self->PROPAGATE($f,$l);
454              
455 4 50       14 if (@_%2) {
456 0         0 warn sprintf('bad parameter list to %s->rethrow(...)'
457             .'at file %d, line %d: odd number of elements in property-value '
458             .'list, property value has no property name and will be '
459             ."discarded (common causes: you have %s string)\n"
460             ,$f, $l, $sAddOrOmit);
461 0         0 shift @_;
462             }
463 4 50       152 $self->replaceProperties({@_}) if (@_);
464 4         26 return $self;
465             }
466              
467             #------------------------------------------------------------------
468             # Traps warnings and reworks them so that they tell the user how
469             # to fix the problem rather than obscurely complain about an
470             # invisible sprintf with uninitialized values that seem to come from
471             # no where (and make Exception::Lite look like it is broken)
472              
473             sub _sprintf {
474 7     7   9 my $sMsg;
475             my $sWarn;
476              
477             {
478 7 100   4   10 local $SIG{__WARN__} = sub { $sWarn=$_[0] if !defined($sWarn) };
  7         44  
  4         36  
479              
480             # sprintf has prototype ($@)
481 7         15 my $sFormat = shift;
482 7         60 $sMsg = sprintf($sFormat, @_);
483             }
484              
485 7 100       19 if (defined($sWarn)) {
486 2         4 my $sReason='';
487 2         13 my ($f, $l, $s) = (caller(1))[1,2,3];
488 2         20 $s =~ s/::(\w+)\z/->$1/;
489 2         9 $sWarn =~ s/sprintf/$s/;
490 2         17 $sWarn =~ s/\s+at\s+[\w\/\.]+\s+line\s+\d+\.\s+\z//;
491 2 50       10 if ($sWarn
492             =~ m{^Use of uninitialized value in|^Missing argument}) {
493 2         3 my $p=$s; $p =~ s/->\w+\z//;
  2         9  
494 2         15 $sReason ="\n Most likely cause: "
495             . "Either you are missing property-value pairs needed to"
496             . "build the message or your exception class's format"
497             . "definition mistakenly has too many placeholders "
498             . "(e.g. %s,%d,etc)\n";
499             }
500 2         13 warn "$sWarn called at file $f, line $l$sReason\n";
501             }
502 7         210 return $sMsg;
503             }
504              
505             #------------------------------------------------------------------
506              
507             sub _shiftProperties {
508 22     22   39 my $cl= shift; my $st=shift; my $sAddOrOmit = shift;
  22         31  
  22         28  
509 22 100       69 if (@_%2) {
510 1         2 $"='|';
511 1         17 warn sprintf('bad parameter list to %s->new(...) at '
512             .'file %s, line %d: odd number of elements in property-value '
513             .'list, property value has no property name and will be '
514             .'discarded (common causes: you have %s string -or- you are '
515             ."using a string as a chained exception)\n"
516             ,$cl,$st->[0]->[0],$st->[0]->[1], $sAddOrOmit);
517 1         7 shift @_;
518             }
519 22         670 return {@_};
520             }
521              
522             #==================================================================
523             # MODULE INITIALIZATION
524             #==================================================================
525              
526             declareExceptionClass(__PACKAGE__ .'::Any');
527             1;