This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Skip test for Module::Load::Conditional that appears to be setting
[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. :-(
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
BT
72sub 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
BT
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
BT
93 }
94 $call_info{sub_name} = $sub_name;
95 return wantarray() ? %call_info : \%call_info;
96}
ca24dfc6 97
66a4a569
BT
98# Transform an argument to a function into a string.
99sub format_arg {
100 my $arg = shift;
8a7acfb9 101 if (ref($arg)) {
3a57e0bb 102 $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
8a7acfb9
YO
103 }elsif (not defined($arg)) {
104 $arg = 'undef';
66a4a569
BT
105 }
106 $arg =~ s/'/\\'/g;
eb2aae6f 107 $arg = str_len_trim($arg, $MaxArgLen);
66a4a569
BT
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
RGS
115 utf8::is_utf8($arg)
116 or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
66a4a569
BT
117 return $arg;
118}
ca24dfc6 119
66a4a569
BT
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.
124sub 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
BT
131# Takes the info from caller() and figures out the name of
132# the sub/require/eval
133sub get_subname {
134 my $info = shift;
976ea96e
RS
135 if (defined($info->{evaltext})) {
136 my $eval = $info->{evaltext};
66a4a569
BT
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
BT
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.
151sub 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 176sub longmess_heavy {
25f5609c 177 return @_ if ref($_[0]); # don't break references as exceptions
66a4a569
BT
178 my $i = long_error_loc();
179 return ret_backtrace($i, @_);
180}
ca24dfc6 181
66a4a569
BT
182# Returns a full stack backtrace starting from where it is
183# told.
184sub 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
SH
196 my %i = caller_info($i);
197 $mess = "$err at $i{file} line $i{line}$tid_msg\n";
66a4a569
BT
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
BT
206sub ret_summary {
207 my ($i, @error) = @_;
66a4a569
BT
208 my $err = join '', @error;
209 $i++;
3b5ca523 210
66a4a569
BT
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
BT
217 my %i = caller_info($i);
218 return "$err at $i{file} line $i{line}$tid_msg\n";
3b5ca523
GS
219}
220
221
66a4a569
BT
222sub 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
BT
230 return 0 unless defined($caller); # What happened?
231 redo if $Internal{$caller};
d735c2ef 232 redo if $CarpInternal{$caller};
66a4a569
BT
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
GS
239}
240
29ddba3b 241
66a4a569
BT
242sub shortmess_heavy {
243 return longmess_heavy(@_) if $Verbose;
25f5609c 244 return @_ if ref($_[0]); # don't break references as exceptions
66a4a569
BT
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 ...
255sub 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
BT
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.
270sub 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
BT
285 return exists $known->{$parent};
286}
3b5ca523 287
66a4a569
BT
288# Takes a package and gives a list of those trusted directly
289sub trusts_directly {
290 my $class = shift;
a3775ca3 291 no strict 'refs';
b5777b26 292 no warnings 'once';
a3775ca3
BT
293 return @{"$class\::CARP_NOT"}
294 ? @{"$class\::CARP_NOT"}
295 : @{"$class\::ISA"};
3b5ca523
GS
296}
297
2981;
66a4a569 299