This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Silence compiler warning in SDBM_File
[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# use strict; # not yet
11
12# On one line so MakeMaker will see it.
13use Carp; our $VERSION = $Carp::VERSION;
14
eb2aae6f 15our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
ca24dfc6 16
66a4a569
BT
17sub caller_info {
18 my $i = shift(@_) + 1;
19 package DB;
20 my %call_info;
21 @call_info{
22 qw(pack file line sub has_args wantarray evaltext is_require)
23 } = caller($i);
24
25 unless (defined $call_info{pack}) {
26 return ();
27 }
28
29 my $sub_name = Carp::get_subname(\%call_info);
30 if ($call_info{has_args}) {
a3775ca3 31 my @args = map {Carp::format_arg($_)} @DB::args;
66a4a569
BT
32 if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
33 $#args = $MaxArgNums;
34 push @args, '...';
35 }
36 # Push the args onto the subroutine
1798c67d 37 $sub_name .= '(' . join (', ', @args) . ')';
66a4a569
BT
38 }
39 $call_info{sub_name} = $sub_name;
40 return wantarray() ? %call_info : \%call_info;
41}
ca24dfc6 42
66a4a569
BT
43# Transform an argument to a function into a string.
44sub format_arg {
45 my $arg = shift;
46 if (not defined($arg)) {
47 $arg = 'undef';
48 }
49 elsif (ref($arg)) {
3a57e0bb 50 $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
66a4a569
BT
51 }
52 $arg =~ s/'/\\'/g;
eb2aae6f 53 $arg = str_len_trim($arg, $MaxArgLen);
66a4a569
BT
54
55 # Quote it?
56 $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
57
58 # The following handling of "control chars" is direct from
59 # the original code - I think it is broken on Unicode though.
60 # Suggestions?
60a23310 61 $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
66a4a569
BT
62 return $arg;
63}
ca24dfc6 64
66a4a569
BT
65# Takes an inheritance cache and a package and returns
66# an anon hash of known inheritances and anon array of
67# inheritances which consequences have not been figured
68# for.
69sub get_status {
70 my $cache = shift;
71 my $pkg = shift;
72 $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
73 return @{$cache->{$pkg}};
74}
ca24dfc6 75
66a4a569
BT
76# Takes the info from caller() and figures out the name of
77# the sub/require/eval
78sub get_subname {
79 my $info = shift;
976ea96e
RS
80 if (defined($info->{evaltext})) {
81 my $eval = $info->{evaltext};
66a4a569
BT
82 if ($info->{is_require}) {
83 return "require $eval";
84 }
85 else {
86 $eval =~ s/([\\\'])/\\$1/g;
976ea96e 87 return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
66a4a569
BT
88 }
89 }
90
91 return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
92}
93
94# Figures out what call (from the point of view of the caller)
95# the long error backtrace should start at.
96sub long_error_loc {
97 my $i;
98 my $lvl = $CarpLevel;
99 {
100 my $pkg = caller(++$i);
101 unless(defined($pkg)) {
102 # This *shouldn't* happen.
103 if (%Internal) {
104 local %Internal;
105 $i = long_error_loc();
106 last;
107 }
108 else {
109 # OK, now I am irritated.
110 return 2;
111 }
112 }
113 redo if $CarpInternal{$pkg};
114 redo unless 0 > --$lvl;
115 redo if $Internal{$pkg};
116 }
117 return $i - 1;
118}
ca24dfc6 119
3cb6de81 120
66a4a569 121sub longmess_heavy {
25f5609c 122 return @_ if ref($_[0]); # don't break references as exceptions
66a4a569
BT
123 my $i = long_error_loc();
124 return ret_backtrace($i, @_);
125}
ca24dfc6 126
66a4a569
BT
127# Returns a full stack backtrace starting from where it is
128# told.
129sub ret_backtrace {
130 my ($i, @error) = @_;
131 my $mess;
132 my $err = join '', @error;
133 $i++;
134
135 my $tid_msg = '';
136 if (defined &Thread::tid) {
137 my $tid = Thread->self->tid;
138 $tid_msg = " thread $tid" if $tid;
139 }
140
59b0a8b7
SH
141 my %i = caller_info($i);
142 $mess = "$err at $i{file} line $i{line}$tid_msg\n";
66a4a569
BT
143
144 while (my %i = caller_info(++$i)) {
145 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
fbb63a9e 146 }
66a4a569 147
25f5609c 148 return $mess;
66a4a569 149}
3b5ca523 150
66a4a569
BT
151sub ret_summary {
152 my ($i, @error) = @_;
66a4a569
BT
153 my $err = join '', @error;
154 $i++;
3b5ca523 155
66a4a569
BT
156 my $tid_msg = '';
157 if (defined &Thread::tid) {
158 my $tid = Thread->self->tid;
159 $tid_msg = " thread $tid" if $tid;
160 }
3b5ca523 161
66a4a569
BT
162 my %i = caller_info($i);
163 return "$err at $i{file} line $i{line}$tid_msg\n";
3b5ca523
GS
164}
165
166
66a4a569
BT
167sub short_error_loc {
168 my $cache;
169 my $i = 1;
170 my $lvl = $CarpLevel;
171 {
172 my $called = caller($i++);
173 my $caller = caller($i);
174 return 0 unless defined($caller); # What happened?
175 redo if $Internal{$caller};
176 redo if $CarpInternal{$called};
177 redo if trusts($called, $caller, $cache);
178 redo if trusts($caller, $called, $cache);
179 redo unless 0 > --$lvl;
180 }
181 return $i - 1;
191f2cf3
GS
182}
183
66a4a569
BT
184sub shortmess_heavy {
185 return longmess_heavy(@_) if $Verbose;
25f5609c 186 return @_ if ref($_[0]); # don't break references as exceptions
66a4a569
BT
187 my $i = short_error_loc();
188 if ($i) {
189 ret_summary($i, @_);
190 }
191 else {
192 longmess_heavy(@_);
193 }
194}
195
196# If a string is too long, trims it with ...
197sub str_len_trim {
198 my $str = shift;
199 my $max = shift || 0;
200 if (2 < $max and $max < length($str)) {
201 substr($str, $max - 3) = '...';
202 }
203 return $str;
204}
191f2cf3 205
66a4a569
BT
206# Takes two packages and an optional cache. Says whether the
207# first inherits from the second.
208#
209# Recursive versions of this have to work to avoid certain
210# possible endless loops, and when following long chains of
211# inheritance are less efficient.
212sub trusts {
213 my $child = shift;
214 my $parent = shift;
215 my $cache = shift || {};
216 my ($known, $partial) = get_status($cache, $child);
217 # Figure out consequences until we have an answer
218 while (@$partial and not exists $known->{$parent}) {
219 my $anc = shift @$partial;
220 next if exists $known->{$anc};
221 $known->{$anc}++;
222 my ($anc_knows, $anc_partial) = get_status($cache, $anc);
223 my @found = keys %$anc_knows;
224 @$known{@found} = ();
225 push @$partial, @$anc_partial;
3b5ca523 226 }
66a4a569
BT
227 return exists $known->{$parent};
228}
3b5ca523 229
66a4a569
BT
230# Takes a package and gives a list of those trusted directly
231sub trusts_directly {
232 my $class = shift;
a3775ca3 233 no strict 'refs';
b5777b26 234 no warnings 'once';
a3775ca3
BT
235 return @{"$class\::CARP_NOT"}
236 ? @{"$class\::CARP_NOT"}
237 : @{"$class\::ISA"};
3b5ca523
GS
238}
239
2401;
66a4a569 241