This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove unused lexical present since change 13426.
[perl5.git] / lib / Carp / Heavy.pm
CommitLineData
b75c8c73 1# Carp::Heavy uses some variables in common with Carp.
3b5ca523 2package Carp;
ca24dfc6 3
ab648d5e
JH
4=head1 NAME
5
4952958f 6Carp::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.
11use Carp; our $VERSION = $Carp::VERSION;
29ddba3b
DM
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
DM
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
DM
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 34our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
ca24dfc6 35
29ddba3b
DM
36# XXX longmess_real and shortmess_real should really be merged into
37# XXX {long|sort}mess_heavy at some point
38
39sub longmess_real {
40 # Icky backwards compatibility wrapper. :-(
d735c2ef
BT
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
DM
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
56sub shortmess_real {
57 # Icky backwards compatibility wrapper. :-(
29ddba3b
DM
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 !)
792941b2
NC
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.
29ddba3b 69
792941b2
NC
70delete $Carp::{shortmess_jmp};
71delete $Carp::{longmess_jmp};
29ddba3b
DM
72*longmess_jmp = *longmess_real;
73*shortmess_jmp = *shortmess_real;
74
75
66a4a569
BT
76sub 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
1798c67d 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.
103sub format_arg {
104 my $arg = shift;
8a7acfb9 105 if (ref($arg)) {
3a57e0bb 106 $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
8a7acfb9
YO
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
e6ddefa8 117 # the original code - it is broken on Unicode though.
66a4a569 118 # Suggestions?
e6ddefa8
RGS
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.
128sub 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
137sub 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.
155sub 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 180sub 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.
188sub 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
59b0a8b7
SH
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
210sub 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
BT
226sub short_error_loc {
227 my $cache;
228 my $i = 1;
229 my $lvl = $CarpLevel;
230 {
231 my $called = caller($i++);
232 my $caller = caller($i);
29ddba3b 233
66a4a569
BT
234 return 0 unless defined($caller); # What happened?
235 redo if $Internal{$caller};
d735c2ef 236 redo if $CarpInternal{$caller};
66a4a569
BT
237 redo if $CarpInternal{$called};
238 redo if trusts($called, $caller, $cache);
239 redo if trusts($caller, $called, $cache);
240 redo unless 0 > --$lvl;
241 }
242 return $i - 1;
191f2cf3
GS
243}
244
29ddba3b 245
66a4a569
BT
246sub shortmess_heavy {
247 return longmess_heavy(@_) if $Verbose;
25f5609c 248 return @_ if ref($_[0]); # don't break references as exceptions
66a4a569
BT
249 my $i = short_error_loc();
250 if ($i) {
251 ret_summary($i, @_);
252 }
253 else {
254 longmess_heavy(@_);
255 }
256}
257
258# If a string is too long, trims it with ...
259sub str_len_trim {
260 my $str = shift;
261 my $max = shift || 0;
262 if (2 < $max and $max < length($str)) {
263 substr($str, $max - 3) = '...';
264 }
265 return $str;
266}
191f2cf3 267
66a4a569
BT
268# Takes two packages and an optional cache. Says whether the
269# first inherits from the second.
270#
271# Recursive versions of this have to work to avoid certain
272# possible endless loops, and when following long chains of
273# inheritance are less efficient.
274sub trusts {
275 my $child = shift;
276 my $parent = shift;
277 my $cache = shift || {};
278 my ($known, $partial) = get_status($cache, $child);
279 # Figure out consequences until we have an answer
280 while (@$partial and not exists $known->{$parent}) {
281 my $anc = shift @$partial;
282 next if exists $known->{$anc};
283 $known->{$anc}++;
284 my ($anc_knows, $anc_partial) = get_status($cache, $anc);
285 my @found = keys %$anc_knows;
286 @$known{@found} = ();
287 push @$partial, @$anc_partial;
3b5ca523 288 }
66a4a569
BT
289 return exists $known->{$parent};
290}
3b5ca523 291
66a4a569
BT
292# Takes a package and gives a list of those trusted directly
293sub trusts_directly {
294 my $class = shift;
a3775ca3 295 no strict 'refs';
b5777b26 296 no warnings 'once';
a3775ca3
BT
297 return @{"$class\::CARP_NOT"}
298 ? @{"$class\::CARP_NOT"}
299 : @{"$class\::ISA"};
3b5ca523
GS
300}
301
3021;
66a4a569 303