This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Strictures, dual variables
[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
6Carp heavy machinery - no user serviceable parts inside
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
15our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $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}) {
25f5609c 31 my @args = map {Carp::format_arg($_)} @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
37 $sub_name .= '(' . join (',', @args) . ')';
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;
53 $arg = str_len_trim($arg, $MaxLenArg);
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;
80 if (defined($info->{eval})) {
81 my $eval = $info->{eval};
82 if ($info->{is_require}) {
83 return "require $eval";
84 }
85 else {
86 $eval =~ s/([\\\'])/\\$1/g;
87 return str_len_trim($eval, $MaxEvalLen);
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
25f5609c 141 { if ($err =~ /\n$/) { # extra block to localise $1 etc
66a4a569
BT
142 $mess = $err;
143 }
144 else {
145 my %i = caller_info($i);
146 $mess = "$err at $i{file} line $i{line}$tid_msg\n";
25f5609c 147 }}
66a4a569
BT
148
149 while (my %i = caller_info(++$i)) {
150 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
fbb63a9e 151 }
66a4a569 152
25f5609c 153 return $mess;
66a4a569 154}
3b5ca523 155
66a4a569
BT
156sub ret_summary {
157 my ($i, @error) = @_;
158 my $mess;
159 my $err = join '', @error;
160 $i++;
3b5ca523 161
66a4a569
BT
162 my $tid_msg = '';
163 if (defined &Thread::tid) {
164 my $tid = Thread->self->tid;
165 $tid_msg = " thread $tid" if $tid;
166 }
3b5ca523 167
66a4a569
BT
168 my %i = caller_info($i);
169 return "$err at $i{file} line $i{line}$tid_msg\n";
3b5ca523
GS
170}
171
172
66a4a569
BT
173sub short_error_loc {
174 my $cache;
175 my $i = 1;
176 my $lvl = $CarpLevel;
177 {
178 my $called = caller($i++);
179 my $caller = caller($i);
180 return 0 unless defined($caller); # What happened?
181 redo if $Internal{$caller};
182 redo if $CarpInternal{$called};
183 redo if trusts($called, $caller, $cache);
184 redo if trusts($caller, $called, $cache);
185 redo unless 0 > --$lvl;
186 }
187 return $i - 1;
191f2cf3
GS
188}
189
66a4a569
BT
190sub shortmess_heavy {
191 return longmess_heavy(@_) if $Verbose;
25f5609c 192 return @_ if ref($_[0]); # don't break references as exceptions
66a4a569
BT
193 my $i = short_error_loc();
194 if ($i) {
195 ret_summary($i, @_);
196 }
197 else {
198 longmess_heavy(@_);
199 }
200}
201
202# If a string is too long, trims it with ...
203sub str_len_trim {
204 my $str = shift;
205 my $max = shift || 0;
206 if (2 < $max and $max < length($str)) {
207 substr($str, $max - 3) = '...';
208 }
209 return $str;
210}
191f2cf3 211
66a4a569
BT
212# Takes two packages and an optional cache. Says whether the
213# first inherits from the second.
214#
215# Recursive versions of this have to work to avoid certain
216# possible endless loops, and when following long chains of
217# inheritance are less efficient.
218sub trusts {
219 my $child = shift;
220 my $parent = shift;
221 my $cache = shift || {};
222 my ($known, $partial) = get_status($cache, $child);
223 # Figure out consequences until we have an answer
224 while (@$partial and not exists $known->{$parent}) {
225 my $anc = shift @$partial;
226 next if exists $known->{$anc};
227 $known->{$anc}++;
228 my ($anc_knows, $anc_partial) = get_status($cache, $anc);
229 my @found = keys %$anc_knows;
230 @$known{@found} = ();
231 push @$partial, @$anc_partial;
3b5ca523 232 }
66a4a569
BT
233 return exists $known->{$parent};
234}
3b5ca523 235
66a4a569
BT
236# Takes a package and gives a list of those trusted directly
237sub trusts_directly {
238 my $class = shift;
239 return @{"$class\::ISA"};
3b5ca523
GS
240}
241
2421;
66a4a569 243