Commit | Line | Data |
---|---|---|
b75c8c73 | 1 | # Carp::Heavy uses some variables in common with Carp. |
3b5ca523 | 2 | package Carp; |
ca24dfc6 | 3 | |
ab648d5e JH |
4 | =head1 NAME |
5 | ||
bf0e938b | 6 | Carp::Heavy - heavy machinery, no user serviceable parts inside |
ab648d5e JH |
7 | |
8 | =cut | |
9 | ||
b75c8c73 MS |
10 | # On one line so MakeMaker will see it. |
11 | use Carp; our $VERSION = $Carp::VERSION; | |
d06e5290 BT |
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 | ||
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 | ||
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 | |
d06e5290 BT |
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. :-( | |
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. | |
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 | local @CARP_NOT = caller(); | |
59 | shortmess_heavy(@_); | |
60 | }; | |
61 | ||
62 | # replace the two hooks added by Carp | |
63 | ||
64 | # aliasing the whole glob rather than just the CV slot avoids 'redefined' | |
65 | # warnings, even in the presence of perl -W (as used by lib/warnings.t !) | |
66 | # However it has the potential to create infinite loops, if somehow Carp | |
67 | # is forcibly reloaded, but $INC{"Carp/Heavy.pm"} remains true. | |
68 | # Hence the extra hack of deleting the previous typeglob first. | |
69 | ||
70 | delete $Carp::{shortmess_jmp}; | |
71 | delete $Carp::{longmess_jmp}; | |
72 | *longmess_jmp = *longmess_real; | |
73 | *shortmess_jmp = *shortmess_real; | |
74 | ||
75 | ||
66a4a569 BT |
76 | sub caller_info { |
77 | my $i = shift(@_) + 1; | |
78 | package DB; | |
79 | my %call_info; | |
80 | @call_info{ | |
81 | qw(pack file line sub has_args wantarray evaltext is_require) | |
82 | } = caller($i); | |
83 | ||
84 | unless (defined $call_info{pack}) { | |
85 | return (); | |
86 | } | |
87 | ||
88 | my $sub_name = Carp::get_subname(\%call_info); | |
89 | if ($call_info{has_args}) { | |
a3775ca3 | 90 | my @args = map {Carp::format_arg($_)} @DB::args; |
66a4a569 BT |
91 | if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? |
92 | $#args = $MaxArgNums; | |
93 | push @args, '...'; | |
94 | } | |
95 | # Push the args onto the subroutine | |
337e4d5f | 96 | $sub_name .= '(' . join (', ', @args) . ')'; |
66a4a569 BT |
97 | } |
98 | $call_info{sub_name} = $sub_name; | |
99 | return wantarray() ? %call_info : \%call_info; | |
100 | } | |
ca24dfc6 | 101 | |
66a4a569 BT |
102 | # Transform an argument to a function into a string. |
103 | sub format_arg { | |
104 | my $arg = shift; | |
ccade462 | 105 | if (ref($arg)) { |
3a57e0bb | 106 | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; |
ccade462 NC |
107 | }elsif (not defined($arg)) { |
108 | $arg = 'undef'; | |
66a4a569 BT |
109 | } |
110 | $arg =~ s/'/\\'/g; | |
eb2aae6f | 111 | $arg = str_len_trim($arg, $MaxArgLen); |
66a4a569 BT |
112 | |
113 | # Quote it? | |
114 | $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; | |
115 | ||
116 | # The following handling of "control chars" is direct from | |
ccade462 | 117 | # the original code - it is broken on Unicode though. |
66a4a569 | 118 | # Suggestions? |
ccade462 NC |
119 | utf8::is_utf8($arg) |
120 | or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; | |
66a4a569 BT |
121 | return $arg; |
122 | } | |
ca24dfc6 | 123 | |
66a4a569 BT |
124 | # Takes an inheritance cache and a package and returns |
125 | # an anon hash of known inheritances and anon array of | |
126 | # inheritances which consequences have not been figured | |
127 | # for. | |
128 | sub get_status { | |
129 | my $cache = shift; | |
130 | my $pkg = shift; | |
131 | $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; | |
132 | return @{$cache->{$pkg}}; | |
133 | } | |
ca24dfc6 | 134 | |
66a4a569 BT |
135 | # Takes the info from caller() and figures out the name of |
136 | # the sub/require/eval | |
137 | sub get_subname { | |
138 | my $info = shift; | |
976ea96e RS |
139 | if (defined($info->{evaltext})) { |
140 | my $eval = $info->{evaltext}; | |
66a4a569 BT |
141 | if ($info->{is_require}) { |
142 | return "require $eval"; | |
143 | } | |
144 | else { | |
145 | $eval =~ s/([\\\'])/\\$1/g; | |
976ea96e | 146 | return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'"; |
66a4a569 BT |
147 | } |
148 | } | |
149 | ||
150 | return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; | |
151 | } | |
152 | ||
153 | # Figures out what call (from the point of view of the caller) | |
154 | # the long error backtrace should start at. | |
155 | sub long_error_loc { | |
156 | my $i; | |
157 | my $lvl = $CarpLevel; | |
158 | { | |
159 | my $pkg = caller(++$i); | |
160 | unless(defined($pkg)) { | |
161 | # This *shouldn't* happen. | |
162 | if (%Internal) { | |
163 | local %Internal; | |
164 | $i = long_error_loc(); | |
165 | last; | |
166 | } | |
167 | else { | |
168 | # OK, now I am irritated. | |
169 | return 2; | |
170 | } | |
171 | } | |
172 | redo if $CarpInternal{$pkg}; | |
173 | redo unless 0 > --$lvl; | |
174 | redo if $Internal{$pkg}; | |
175 | } | |
176 | return $i - 1; | |
177 | } | |
ca24dfc6 | 178 | |
3cb6de81 | 179 | |
66a4a569 | 180 | sub longmess_heavy { |
25f5609c | 181 | return @_ if ref($_[0]); # don't break references as exceptions |
66a4a569 BT |
182 | my $i = long_error_loc(); |
183 | return ret_backtrace($i, @_); | |
184 | } | |
ca24dfc6 | 185 | |
66a4a569 BT |
186 | # Returns a full stack backtrace starting from where it is |
187 | # told. | |
188 | sub ret_backtrace { | |
189 | my ($i, @error) = @_; | |
190 | my $mess; | |
191 | my $err = join '', @error; | |
192 | $i++; | |
193 | ||
194 | my $tid_msg = ''; | |
195 | if (defined &Thread::tid) { | |
196 | my $tid = Thread->self->tid; | |
197 | $tid_msg = " thread $tid" if $tid; | |
198 | } | |
199 | ||
ab91823c NC |
200 | my %i = caller_info($i); |
201 | $mess = "$err at $i{file} line $i{line}$tid_msg\n"; | |
66a4a569 BT |
202 | |
203 | while (my %i = caller_info(++$i)) { | |
204 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; | |
fbb63a9e | 205 | } |
66a4a569 | 206 | |
25f5609c | 207 | return $mess; |
66a4a569 | 208 | } |
3b5ca523 | 209 | |
66a4a569 BT |
210 | sub ret_summary { |
211 | my ($i, @error) = @_; | |
66a4a569 BT |
212 | my $err = join '', @error; |
213 | $i++; | |
3b5ca523 | 214 | |
66a4a569 BT |
215 | my $tid_msg = ''; |
216 | if (defined &Thread::tid) { | |
217 | my $tid = Thread->self->tid; | |
218 | $tid_msg = " thread $tid" if $tid; | |
219 | } | |
3b5ca523 | 220 | |
66a4a569 BT |
221 | my %i = caller_info($i); |
222 | return "$err at $i{file} line $i{line}$tid_msg\n"; | |
3b5ca523 GS |
223 | } |
224 | ||
225 | ||
66a4a569 | 226 | sub short_error_loc { |
d06e5290 BT |
227 | # You have to create your (hash)ref out here, rather than defaulting it |
228 | # inside trusts *on a lexical*, as you want it to persist across calls. | |
229 | # (You can default it on $_[2], but that gets messy) | |
230 | my $cache = {}; | |
66a4a569 BT |
231 | my $i = 1; |
232 | my $lvl = $CarpLevel; | |
233 | { | |
234 | my $called = caller($i++); | |
235 | my $caller = caller($i); | |
d06e5290 | 236 | |
66a4a569 BT |
237 | return 0 unless defined($caller); # What happened? |
238 | redo if $Internal{$caller}; | |
d06e5290 | 239 | redo if $CarpInternal{$caller}; |
66a4a569 BT |
240 | redo if $CarpInternal{$called}; |
241 | redo if trusts($called, $caller, $cache); | |
242 | redo if trusts($caller, $called, $cache); | |
243 | redo unless 0 > --$lvl; | |
244 | } | |
245 | return $i - 1; | |
191f2cf3 GS |
246 | } |
247 | ||
d06e5290 | 248 | |
66a4a569 BT |
249 | sub shortmess_heavy { |
250 | return longmess_heavy(@_) if $Verbose; | |
25f5609c | 251 | return @_ if ref($_[0]); # don't break references as exceptions |
66a4a569 BT |
252 | my $i = short_error_loc(); |
253 | if ($i) { | |
254 | ret_summary($i, @_); | |
255 | } | |
256 | else { | |
257 | longmess_heavy(@_); | |
258 | } | |
259 | } | |
260 | ||
261 | # If a string is too long, trims it with ... | |
262 | sub str_len_trim { | |
263 | my $str = shift; | |
264 | my $max = shift || 0; | |
265 | if (2 < $max and $max < length($str)) { | |
266 | substr($str, $max - 3) = '...'; | |
267 | } | |
268 | return $str; | |
269 | } | |
191f2cf3 | 270 | |
66a4a569 BT |
271 | # Takes two packages and an optional cache. Says whether the |
272 | # first inherits from the second. | |
273 | # | |
274 | # Recursive versions of this have to work to avoid certain | |
275 | # possible endless loops, and when following long chains of | |
276 | # inheritance are less efficient. | |
277 | sub trusts { | |
278 | my $child = shift; | |
279 | my $parent = shift; | |
d06e5290 | 280 | my $cache = shift; |
66a4a569 BT |
281 | my ($known, $partial) = get_status($cache, $child); |
282 | # Figure out consequences until we have an answer | |
283 | while (@$partial and not exists $known->{$parent}) { | |
284 | my $anc = shift @$partial; | |
285 | next if exists $known->{$anc}; | |
286 | $known->{$anc}++; | |
287 | my ($anc_knows, $anc_partial) = get_status($cache, $anc); | |
288 | my @found = keys %$anc_knows; | |
289 | @$known{@found} = (); | |
290 | push @$partial, @$anc_partial; | |
3b5ca523 | 291 | } |
66a4a569 BT |
292 | return exists $known->{$parent}; |
293 | } | |
3b5ca523 | 294 | |
66a4a569 BT |
295 | # Takes a package and gives a list of those trusted directly |
296 | sub trusts_directly { | |
297 | my $class = shift; | |
a3775ca3 | 298 | no strict 'refs'; |
b5777b26 | 299 | no warnings 'once'; |
a3775ca3 BT |
300 | return @{"$class\::CARP_NOT"} |
301 | ? @{"$class\::CARP_NOT"} | |
302 | : @{"$class\::ISA"}; | |
3b5ca523 GS |
303 | } |
304 | ||
305 | 1; | |
66a4a569 | 306 |