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; |