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