Commit | Line | Data |
b75c8c73 |
1 | # Carp::Heavy uses some variables in common with Carp. |
3b5ca523 |
2 | package Carp; |
ca24dfc6 |
3 | |
ab648d5e |
4 | =head1 NAME |
5 | |
4952958f |
6 | Carp::Heavy - heavy machinery, no user serviceable parts inside |
ab648d5e |
7 | |
8 | =cut |
9 | |
b75c8c73 |
10 | # On one line so MakeMaker will see it. |
11 | use Carp; our $VERSION = $Carp::VERSION; |
29ddba3b |
12 | # use strict; # not yet |
13 | |
14 | # 'use Carp' just installs some very lightweight stubs; the first time |
15 | # these are called, they require Carp::Heavy which installs the real |
16 | # routines. |
17 | |
29ddba3b |
18 | # The members of %Internal are packages that are internal to perl. |
19 | # Carp will not report errors from within these packages if it |
20 | # can. The members of %CarpInternal are internal to Perl's warning |
21 | # system. Carp will not report errors from within these packages |
22 | # either, and will not report calls *to* these packages for carp and |
23 | # croak. They replace $CarpLevel, which is deprecated. The |
24 | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval |
25 | # text and function arguments should be formatted when printed. |
26 | |
29ddba3b |
27 | # disable these by default, so they can live w/o require Carp |
28 | $CarpInternal{Carp}++; |
29 | $CarpInternal{warnings}++; |
30 | $Internal{Exporter}++; |
31 | $Internal{'Exporter::Heavy'}++; |
32 | |
b75c8c73 |
33 | |
eb2aae6f |
34 | our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose); |
ca24dfc6 |
35 | |
29ddba3b |
36 | # XXX longmess_real and shortmess_real should really be merged into |
37 | # XXX {long|sort}mess_heavy at some point |
38 | |
39 | sub longmess_real { |
40 | # Icky backwards compatibility wrapper. :-( |
d735c2ef |
41 | # |
42 | # The story is that the original implementation hard-coded the |
43 | # number of call levels to go back, so calls to longmess were off |
44 | # by one. Other code began calling longmess and expecting this |
45 | # behaviour, so the replacement has to emulate that behaviour. |
29ddba3b |
46 | my $call_pack = caller(); |
47 | if ($Internal{$call_pack} or $CarpInternal{$call_pack}) { |
48 | return longmess_heavy(@_); |
49 | } |
50 | else { |
51 | local $CarpLevel = $CarpLevel + 1; |
52 | return longmess_heavy(@_); |
53 | } |
54 | }; |
55 | |
56 | sub shortmess_real { |
57 | # Icky backwards compatibility wrapper. :-( |
58 | my $call_pack = caller(); |
59 | local @CARP_NOT = caller(); |
60 | shortmess_heavy(@_); |
61 | }; |
62 | |
63 | # replace the two hooks added by Carp |
64 | |
65 | # aliasing the whole glob rather than just the CV slot avoids 'redefined' |
66 | # warnings, even in the presence of perl -W (as used by lib/warnings.t !) |
67 | |
68 | *longmess_jmp = *longmess_real; |
69 | *shortmess_jmp = *shortmess_real; |
70 | |
71 | |
66a4a569 |
72 | sub caller_info { |
73 | my $i = shift(@_) + 1; |
74 | package DB; |
75 | my %call_info; |
76 | @call_info{ |
77 | qw(pack file line sub has_args wantarray evaltext is_require) |
78 | } = caller($i); |
79 | |
80 | unless (defined $call_info{pack}) { |
81 | return (); |
82 | } |
83 | |
84 | my $sub_name = Carp::get_subname(\%call_info); |
85 | if ($call_info{has_args}) { |
a3775ca3 |
86 | my @args = map {Carp::format_arg($_)} @DB::args; |
66a4a569 |
87 | if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? |
88 | $#args = $MaxArgNums; |
89 | push @args, '...'; |
90 | } |
91 | # Push the args onto the subroutine |
1798c67d |
92 | $sub_name .= '(' . join (', ', @args) . ')'; |
66a4a569 |
93 | } |
94 | $call_info{sub_name} = $sub_name; |
95 | return wantarray() ? %call_info : \%call_info; |
96 | } |
ca24dfc6 |
97 | |
66a4a569 |
98 | # Transform an argument to a function into a string. |
99 | sub format_arg { |
100 | my $arg = shift; |
8a7acfb9 |
101 | if (ref($arg)) { |
3a57e0bb |
102 | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; |
8a7acfb9 |
103 | }elsif (not defined($arg)) { |
104 | $arg = 'undef'; |
66a4a569 |
105 | } |
106 | $arg =~ s/'/\\'/g; |
eb2aae6f |
107 | $arg = str_len_trim($arg, $MaxArgLen); |
66a4a569 |
108 | |
109 | # Quote it? |
110 | $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; |
111 | |
112 | # The following handling of "control chars" is direct from |
e6ddefa8 |
113 | # the original code - it is broken on Unicode though. |
66a4a569 |
114 | # Suggestions? |
e6ddefa8 |
115 | utf8::is_utf8($arg) |
116 | or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; |
66a4a569 |
117 | return $arg; |
118 | } |
ca24dfc6 |
119 | |
66a4a569 |
120 | # Takes an inheritance cache and a package and returns |
121 | # an anon hash of known inheritances and anon array of |
122 | # inheritances which consequences have not been figured |
123 | # for. |
124 | sub get_status { |
125 | my $cache = shift; |
126 | my $pkg = shift; |
127 | $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; |
128 | return @{$cache->{$pkg}}; |
129 | } |
ca24dfc6 |
130 | |
66a4a569 |
131 | # Takes the info from caller() and figures out the name of |
132 | # the sub/require/eval |
133 | sub get_subname { |
134 | my $info = shift; |
976ea96e |
135 | if (defined($info->{evaltext})) { |
136 | my $eval = $info->{evaltext}; |
66a4a569 |
137 | if ($info->{is_require}) { |
138 | return "require $eval"; |
139 | } |
140 | else { |
141 | $eval =~ s/([\\\'])/\\$1/g; |
976ea96e |
142 | return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'"; |
66a4a569 |
143 | } |
144 | } |
145 | |
146 | return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; |
147 | } |
148 | |
149 | # Figures out what call (from the point of view of the caller) |
150 | # the long error backtrace should start at. |
151 | sub long_error_loc { |
152 | my $i; |
153 | my $lvl = $CarpLevel; |
154 | { |
155 | my $pkg = caller(++$i); |
156 | unless(defined($pkg)) { |
157 | # This *shouldn't* happen. |
158 | if (%Internal) { |
159 | local %Internal; |
160 | $i = long_error_loc(); |
161 | last; |
162 | } |
163 | else { |
164 | # OK, now I am irritated. |
165 | return 2; |
166 | } |
167 | } |
168 | redo if $CarpInternal{$pkg}; |
169 | redo unless 0 > --$lvl; |
170 | redo if $Internal{$pkg}; |
171 | } |
172 | return $i - 1; |
173 | } |
ca24dfc6 |
174 | |
3cb6de81 |
175 | |
66a4a569 |
176 | sub longmess_heavy { |
25f5609c |
177 | return @_ if ref($_[0]); # don't break references as exceptions |
66a4a569 |
178 | my $i = long_error_loc(); |
179 | return ret_backtrace($i, @_); |
180 | } |
ca24dfc6 |
181 | |
66a4a569 |
182 | # Returns a full stack backtrace starting from where it is |
183 | # told. |
184 | sub ret_backtrace { |
185 | my ($i, @error) = @_; |
186 | my $mess; |
187 | my $err = join '', @error; |
188 | $i++; |
189 | |
190 | my $tid_msg = ''; |
191 | if (defined &Thread::tid) { |
192 | my $tid = Thread->self->tid; |
193 | $tid_msg = " thread $tid" if $tid; |
194 | } |
195 | |
59b0a8b7 |
196 | my %i = caller_info($i); |
197 | $mess = "$err at $i{file} line $i{line}$tid_msg\n"; |
66a4a569 |
198 | |
199 | while (my %i = caller_info(++$i)) { |
200 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; |
fbb63a9e |
201 | } |
66a4a569 |
202 | |
25f5609c |
203 | return $mess; |
66a4a569 |
204 | } |
3b5ca523 |
205 | |
66a4a569 |
206 | sub ret_summary { |
207 | my ($i, @error) = @_; |
66a4a569 |
208 | my $err = join '', @error; |
209 | $i++; |
3b5ca523 |
210 | |
66a4a569 |
211 | my $tid_msg = ''; |
212 | if (defined &Thread::tid) { |
213 | my $tid = Thread->self->tid; |
214 | $tid_msg = " thread $tid" if $tid; |
215 | } |
3b5ca523 |
216 | |
66a4a569 |
217 | my %i = caller_info($i); |
218 | return "$err at $i{file} line $i{line}$tid_msg\n"; |
3b5ca523 |
219 | } |
220 | |
221 | |
66a4a569 |
222 | sub short_error_loc { |
223 | my $cache; |
224 | my $i = 1; |
225 | my $lvl = $CarpLevel; |
226 | { |
227 | my $called = caller($i++); |
228 | my $caller = caller($i); |
29ddba3b |
229 | |
66a4a569 |
230 | return 0 unless defined($caller); # What happened? |
231 | redo if $Internal{$caller}; |
d735c2ef |
232 | redo if $CarpInternal{$caller}; |
66a4a569 |
233 | redo if $CarpInternal{$called}; |
234 | redo if trusts($called, $caller, $cache); |
235 | redo if trusts($caller, $called, $cache); |
236 | redo unless 0 > --$lvl; |
237 | } |
238 | return $i - 1; |
191f2cf3 |
239 | } |
240 | |
29ddba3b |
241 | |
66a4a569 |
242 | sub shortmess_heavy { |
243 | return longmess_heavy(@_) if $Verbose; |
25f5609c |
244 | return @_ if ref($_[0]); # don't break references as exceptions |
66a4a569 |
245 | my $i = short_error_loc(); |
246 | if ($i) { |
247 | ret_summary($i, @_); |
248 | } |
249 | else { |
250 | longmess_heavy(@_); |
251 | } |
252 | } |
253 | |
254 | # If a string is too long, trims it with ... |
255 | sub str_len_trim { |
256 | my $str = shift; |
257 | my $max = shift || 0; |
258 | if (2 < $max and $max < length($str)) { |
259 | substr($str, $max - 3) = '...'; |
260 | } |
261 | return $str; |
262 | } |
191f2cf3 |
263 | |
66a4a569 |
264 | # Takes two packages and an optional cache. Says whether the |
265 | # first inherits from the second. |
266 | # |
267 | # Recursive versions of this have to work to avoid certain |
268 | # possible endless loops, and when following long chains of |
269 | # inheritance are less efficient. |
270 | sub trusts { |
271 | my $child = shift; |
272 | my $parent = shift; |
273 | my $cache = shift || {}; |
274 | my ($known, $partial) = get_status($cache, $child); |
275 | # Figure out consequences until we have an answer |
276 | while (@$partial and not exists $known->{$parent}) { |
277 | my $anc = shift @$partial; |
278 | next if exists $known->{$anc}; |
279 | $known->{$anc}++; |
280 | my ($anc_knows, $anc_partial) = get_status($cache, $anc); |
281 | my @found = keys %$anc_knows; |
282 | @$known{@found} = (); |
283 | push @$partial, @$anc_partial; |
3b5ca523 |
284 | } |
66a4a569 |
285 | return exists $known->{$parent}; |
286 | } |
3b5ca523 |
287 | |
66a4a569 |
288 | # Takes a package and gives a list of those trusted directly |
289 | sub trusts_directly { |
290 | my $class = shift; |
a3775ca3 |
291 | no strict 'refs'; |
b5777b26 |
292 | no warnings 'once'; |
a3775ca3 |
293 | return @{"$class\::CARP_NOT"} |
294 | ? @{"$class\::CARP_NOT"} |
295 | : @{"$class\::ISA"}; |
3b5ca523 |
296 | } |
297 | |
298 | 1; |
66a4a569 |
299 | |