1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
|
package Carp;
=head1 NAME
Carp::Heavy - Carp guts
=head1 SYNOPIS
(internal use only)
=head1 DESCRIPTION
No user-serviceable parts inside.
=cut
# This package is heavily used. Be small. Be fast. Be good.
# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
# _almost_ complete understanding of the package. Corrections and
# comments are welcome.
# longmess() crawls all the way up the stack reporting on all the function
# calls made. The error string, $error, is originally constructed from the
# arguments passed into longmess() via confess(), cluck() or shortmess().
# This gets appended with the stack trace messages which are generated for
# each function call on the stack.
sub longmess_heavy {
return @_ if ref $_[0];
my $error = join '', @_;
my $mess = "";
my $i = 1 + $CarpLevel;
my ($pack,$file,$line,$sub,$hargs,$eval,$require);
my (@a);
#
# crawl up the stack....
#
while (do { { package DB; @a = caller($i++) } } ) {
# get copies of the variables returned from caller()
($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
#
# if the $error error string is newline terminated then it
# is copied into $mess. Otherwise, $mess gets set (at the end of
# the 'else' section below) to one of two things. The first time
# through, it is set to the "$error at $file line $line" message.
# $error is then set to 'called' which triggers subsequent loop
# iterations to append $sub to $mess before appending the "$error
# at $file line $line" which now actually reads "called at $file line
# $line". Thus, the stack trace message is constructed:
#
# first time: $mess = $error at $file line $line
# subsequent times: $mess .= $sub $error at $file line $line
# ^^^^^^
# "called"
if ($error =~ m/\n$/) {
$mess .= $error;
} else {
# Build a string, $sub, which names the sub-routine called.
# This may also be "require ...", "eval '...' or "eval {...}"
if (defined $eval) {
if ($require) {
$sub = "require $eval";
} else {
$eval =~ s/([\\\'])/\\$1/g;
if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
substr($eval,$MaxEvalLen) = '...';
}
$sub = "eval '$eval'";
}
} elsif ($sub eq '(eval)') {
$sub = 'eval {...}';
}
# if there are any arguments in the sub-routine call, format
# them according to the format variables defined earlier in
# this file and join them onto the $sub sub-routine string
if ($hargs) {
# we may trash some of the args so we take a copy
@a = @DB::args; # must get local copy of args
# don't print any more than $MaxArgNums
if ($MaxArgNums and @a > $MaxArgNums) {
# cap the length of $#a and set the last element to '...'
$#a = $MaxArgNums;
$a[$#a] = "...";
}
for (@a) {
# set args to the string "undef" if undefined
$_ = "undef", next unless defined $_;
if (ref $_) {
# force reference to string representation
$_ .= '';
s/'/\\'/g;
}
else {
s/'/\\'/g;
# terminate the string early with '...' if too long
substr($_,$MaxArgLen) = '...'
if $MaxArgLen and $MaxArgLen < length;
}
# 'quote' arg unless it looks like a number
$_ = "'$_'" unless /^-?[\d.]+$/;
# print high-end chars as 'M-<char>'
s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
# print remaining control chars as ^<char>
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
}
# append ('all', 'the', 'arguments') to the $sub string
$sub .= '(' . join(', ', @a) . ')';
}
# here's where the error message, $mess, gets constructed
$mess .= "\t$sub " if $error eq "called";
$mess .= "$error at $file line $line";
if (defined &Thread::tid) {
my $tid = Thread->self->tid;
$mess .= " thread $tid" if $tid;
}
$mess .= "\n";
}
# we don't need to print the actual error message again so we can
# change this to "called" so that the string "$error at $file line
# $line" makes sense as "called at $file line $line".
$error = "called";
}
$mess || $error;
}
# ancestors() returns the complete set of ancestors of a module
sub ancestors($$);
sub ancestors($$){
my( $pack, $href ) = @_;
if( @{"${pack}::ISA"} ){
my $risa = \@{"${pack}::ISA"};
my %tree = ();
@tree{@$risa} = ();
foreach my $mod ( @$risa ){
# visit ancestors - if not already in the gallery
if( ! defined( $$href{$mod} ) ){
my @ancs = ancestors( $mod, $href );
@tree{@ancs} = ();
}
}
return ( keys( %tree ) );
} else {
return ();
}
}
# shortmess() is called by carp() and croak() to skip all the way up to
# the top-level caller's package and report the error from there. confess()
# and cluck() generate a full stack trace so they call longmess() to
# generate that. In verbose mode shortmess() calls longmess() so
# you always get a stack trace
sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages
goto &longmess_heavy if $Verbose;
return @_ if ref $_[0];
my $error = join '', @_;
my ($prevpack) = caller(1);
my $extra = $CarpLevel;
my @Clans = ( $prevpack );
my $i = 2;
my ($pack,$file,$line);
# when reporting an error, we want to report it from the context of the
# calling package. So what is the calling package? Within a module,
# there may be many calls between methods and perhaps between sub-classes
# and super-classes, but the user isn't interested in what happens
# inside the package. We start by building a hash array which keeps
# track of all the packages to which the calling package belongs. We
# do this by examining its @ISA variable. Any call from a base class
# method (one of our caller's @ISA packages) can be ignored
my %isa;
# merge all the caller's @ISA packages and ancestors into %isa.
my @pars = ancestors( $prevpack, \%isa );
@isa{@pars} = () if @pars;
$isa{$prevpack} = 1;
# now we crawl up the calling stack and look at all the packages in
# there. For each package, we look to see if it has an @ISA and then
# we see if our caller features in that list. That would imply that
# our caller is a derived class of that package and its calls can also
# be ignored
CALLER:
while (($pack,$file,$line) = caller($i++)) {
# Chances are, the caller's caller (or its caller...) is already
# in the gallery - if so, ignore this caller.
next if exists( $isa{$pack} );
# no: collect this module's ancestors.
my @i = ancestors( $pack, \%isa );
my %i;
if( @i ){
@i{@i} = ();
# check whether our representative of one of the clans is
# in this family tree.
foreach my $cl (@Clans){
if( exists( $i{$cl} ) ){
# yes: merge all of the family tree into %isa
@isa{@i,$pack} = ();
# and here's where we do some more ignoring...
# if the package in question is one of our caller's
# base or derived packages then we can ignore it (skip it)
# and go onto the next.
next CALLER if exists( $isa{$pack} );
last;
}
}
}
# Hey! We've found a package that isn't one of our caller's
# clan....but wait, $extra refers to the number of 'extra' levels
# we should skip up. If $extra > 0 then this is a false alarm.
# We must merge the package into the %isa hash (so we can ignore it
# if it pops up again), decrement $extra, and continue.
if ($extra-- > 0) {
push( @Clans, $pack );
@isa{@i,$pack} = ();
}
else {
# OK! We've got a candidate package. Time to construct the
# relevant error message and return it.
my $msg;
$msg = "$error at $file line $line";
if (defined &Thread::tid) {
my $tid = Thread->self->tid;
$msg .= " thread $tid" if $tid;
}
$msg .= "\n";
return $msg;
}
}
# uh-oh! It looks like we crawled all the way up the stack and
# never found a candidate package. Oh well, let's call longmess
# to generate a full stack trace. We use the magical form of 'goto'
# so that this shortmess() function doesn't appear on the stack
# to further confuse longmess() about it's calling package.
goto &longmess_heavy;
}
1;
|
