Commit | Line | Data |
---|---|---|
b75c8c73 | 1 | # Carp::Heavy uses some variables in common with Carp. |
3b5ca523 | 2 | package Carp; |
ca24dfc6 | 3 | |
ab648d5e JH |
4 | =head1 NAME |
5 | ||
6 | Carp 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. | |
13 | use Carp; our $VERSION = $Carp::VERSION; | |
14 | ||
15 | our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $Verbose); | |
ca24dfc6 | 16 | |
66a4a569 BT |
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}) { | |
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. |
44 | sub 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. | |
69 | sub 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 | |
78 | sub 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. | |
96 | sub 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 | 121 | sub 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. | |
129 | sub 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 |
156 | sub 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 |
173 | sub 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 |
190 | sub 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 ... | |
203 | sub 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. | |
218 | sub 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 |
237 | sub trusts_directly { | |
238 | my $class = shift; | |
239 | return @{"$class\::ISA"}; | |
3b5ca523 GS |
240 | } |
241 | ||
242 | 1; | |
66a4a569 | 243 |