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