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