This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ParseXS.pm: small optimization for "Usage: ..." constant strings
[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
18# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
19# _almost_ complete understanding of the package. Corrections and
20# comments are welcome.
21
22# The members of %Internal are packages that are internal to perl.
23# Carp will not report errors from within these packages if it
24# can. The members of %CarpInternal are internal to Perl's warning
25# system. Carp will not report errors from within these packages
26# either, and will not report calls *to* these packages for carp and
27# croak. They replace $CarpLevel, which is deprecated. The
28# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
29# text and function arguments should be formatted when printed.
30
31# Comments added by Jos I. Boumans <kane@dwim.org> 11-Aug-2004
32# I can not get %CarpInternal or %Internal to work as advertised,
33# therefore leaving it out of the below documentation.
34# $CarpLevel may be decprecated according to the last comment, but
35# after 6 years, it's still around and in heavy use ;)
36
37# disable these by default, so they can live w/o require Carp
38$CarpInternal{Carp}++;
39$CarpInternal{warnings}++;
40$Internal{Exporter}++;
41$Internal{'Exporter::Heavy'}++;
42
b75c8c73 43
eb2aae6f 44our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
ca24dfc6 45
29ddba3b
DM
46# XXX longmess_real and shortmess_real should really be merged into
47# XXX {long|sort}mess_heavy at some point
48
49sub longmess_real {
50 # Icky backwards compatibility wrapper. :-(
51 my $call_pack = caller();
52 if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
53 return longmess_heavy(@_);
54 }
55 else {
56 local $CarpLevel = $CarpLevel + 1;
57 return longmess_heavy(@_);
58 }
59};
60
61sub shortmess_real {
62 # Icky backwards compatibility wrapper. :-(
63 my $call_pack = caller();
64 local @CARP_NOT = caller();
65 shortmess_heavy(@_);
66};
67
68# replace the two hooks added by Carp
69
70# aliasing the whole glob rather than just the CV slot avoids 'redefined'
71# warnings, even in the presence of perl -W (as used by lib/warnings.t !)
72
73*longmess_jmp = *longmess_real;
74*shortmess_jmp = *shortmess_real;
75
76
66a4a569
BT
77sub caller_info {
78 my $i = shift(@_) + 1;
79 package DB;
80 my %call_info;
81 @call_info{
82 qw(pack file line sub has_args wantarray evaltext is_require)
83 } = caller($i);
84
85 unless (defined $call_info{pack}) {
86 return ();
87 }
88
89 my $sub_name = Carp::get_subname(\%call_info);
90 if ($call_info{has_args}) {
a3775ca3 91 my @args = map {Carp::format_arg($_)} @DB::args;
66a4a569
BT
92 if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
93 $#args = $MaxArgNums;
94 push @args, '...';
95 }
96 # Push the args onto the subroutine
1798c67d 97 $sub_name .= '(' . join (', ', @args) . ')';
66a4a569
BT
98 }
99 $call_info{sub_name} = $sub_name;
100 return wantarray() ? %call_info : \%call_info;
101}
ca24dfc6 102
66a4a569
BT
103# Transform an argument to a function into a string.
104sub format_arg {
105 my $arg = shift;
8a7acfb9 106 if (ref($arg)) {
3a57e0bb 107 $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
8a7acfb9
YO
108 }elsif (not defined($arg)) {
109 $arg = 'undef';
66a4a569
BT
110 }
111 $arg =~ s/'/\\'/g;
eb2aae6f 112 $arg = str_len_trim($arg, $MaxArgLen);
66a4a569
BT
113
114 # Quote it?
115 $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
116
117 # The following handling of "control chars" is direct from
e6ddefa8 118 # the original code - it is broken on Unicode though.
66a4a569 119 # Suggestions?
e6ddefa8
RGS
120 utf8::is_utf8($arg)
121 or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
66a4a569
BT
122 return $arg;
123}
ca24dfc6 124
66a4a569
BT
125# Takes an inheritance cache and a package and returns
126# an anon hash of known inheritances and anon array of
127# inheritances which consequences have not been figured
128# for.
129sub get_status {
130 my $cache = shift;
131 my $pkg = shift;
132 $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
133 return @{$cache->{$pkg}};
134}
ca24dfc6 135
66a4a569
BT
136# Takes the info from caller() and figures out the name of
137# the sub/require/eval
138sub get_subname {
139 my $info = shift;
976ea96e
RS
140 if (defined($info->{evaltext})) {
141 my $eval = $info->{evaltext};
66a4a569
BT
142 if ($info->{is_require}) {
143 return "require $eval";
144 }
145 else {
146 $eval =~ s/([\\\'])/\\$1/g;
976ea96e 147 return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
66a4a569
BT
148 }
149 }
150
151 return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
152}
153
154# Figures out what call (from the point of view of the caller)
155# the long error backtrace should start at.
156sub long_error_loc {
157 my $i;
158 my $lvl = $CarpLevel;
159 {
160 my $pkg = caller(++$i);
161 unless(defined($pkg)) {
162 # This *shouldn't* happen.
163 if (%Internal) {
164 local %Internal;
165 $i = long_error_loc();
166 last;
167 }
168 else {
169 # OK, now I am irritated.
170 return 2;
171 }
172 }
173 redo if $CarpInternal{$pkg};
174 redo unless 0 > --$lvl;
175 redo if $Internal{$pkg};
176 }
177 return $i - 1;
178}
ca24dfc6 179
3cb6de81 180
66a4a569 181sub longmess_heavy {
25f5609c 182 return @_ if ref($_[0]); # don't break references as exceptions
66a4a569
BT
183 my $i = long_error_loc();
184 return ret_backtrace($i, @_);
185}
ca24dfc6 186
66a4a569
BT
187# Returns a full stack backtrace starting from where it is
188# told.
189sub ret_backtrace {
190 my ($i, @error) = @_;
191 my $mess;
192 my $err = join '', @error;
193 $i++;
194
195 my $tid_msg = '';
196 if (defined &Thread::tid) {
197 my $tid = Thread->self->tid;
198 $tid_msg = " thread $tid" if $tid;
199 }
200
59b0a8b7
SH
201 my %i = caller_info($i);
202 $mess = "$err at $i{file} line $i{line}$tid_msg\n";
66a4a569
BT
203
204 while (my %i = caller_info(++$i)) {
205 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
fbb63a9e 206 }
66a4a569 207
25f5609c 208 return $mess;
66a4a569 209}
3b5ca523 210
66a4a569
BT
211sub ret_summary {
212 my ($i, @error) = @_;
66a4a569
BT
213 my $err = join '', @error;
214 $i++;
3b5ca523 215
66a4a569
BT
216 my $tid_msg = '';
217 if (defined &Thread::tid) {
218 my $tid = Thread->self->tid;
219 $tid_msg = " thread $tid" if $tid;
220 }
3b5ca523 221
66a4a569
BT
222 my %i = caller_info($i);
223 return "$err at $i{file} line $i{line}$tid_msg\n";
3b5ca523
GS
224}
225
226
66a4a569
BT
227sub short_error_loc {
228 my $cache;
229 my $i = 1;
230 my $lvl = $CarpLevel;
231 {
232 my $called = caller($i++);
233 my $caller = caller($i);
29ddba3b 234
66a4a569
BT
235 return 0 unless defined($caller); # What happened?
236 redo if $Internal{$caller};
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