1 | # Carp::Heavy uses some variables in common with Carp.
|
---|
2 | package Carp;
|
---|
3 |
|
---|
4 | =head1 NAME
|
---|
5 |
|
---|
6 | Carp::Heavy - heavy machinery, no user serviceable parts inside
|
---|
7 |
|
---|
8 | =cut
|
---|
9 |
|
---|
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, $MaxArgLen, $Verbose);
|
---|
16 |
|
---|
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 | my @args = map {Carp::format_arg($_)} @DB::args;
|
---|
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 | }
|
---|
42 |
|
---|
43 | # Transform an argument to a function into a string.
|
---|
44 | sub format_arg {
|
---|
45 | my $arg = shift;
|
---|
46 | if (ref($arg)) {
|
---|
47 | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
|
---|
48 | }elsif (not defined($arg)) {
|
---|
49 | $arg = 'undef';
|
---|
50 | }
|
---|
51 | $arg =~ s/'/\\'/g;
|
---|
52 | $arg = str_len_trim($arg, $MaxArgLen);
|
---|
53 |
|
---|
54 | # Quote it?
|
---|
55 | $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
|
---|
56 |
|
---|
57 | # The following handling of "control chars" is direct from
|
---|
58 | # the original code - it is broken on Unicode though.
|
---|
59 | # Suggestions?
|
---|
60 | utf8::is_utf8($arg)
|
---|
61 | or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
|
---|
62 | return $arg;
|
---|
63 | }
|
---|
64 |
|
---|
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 | }
|
---|
75 |
|
---|
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->{evaltext})) {
|
---|
81 | my $eval = $info->{evaltext};
|
---|
82 | if ($info->{is_require}) {
|
---|
83 | return "require $eval";
|
---|
84 | }
|
---|
85 | else {
|
---|
86 | $eval =~ s/([\\\'])/\\$1/g;
|
---|
87 | return "eval '" . 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 | }
|
---|
119 |
|
---|
120 |
|
---|
121 | sub longmess_heavy {
|
---|
122 | return @_ if ref($_[0]); # don't break references as exceptions
|
---|
123 | my $i = long_error_loc();
|
---|
124 | return ret_backtrace($i, @_);
|
---|
125 | }
|
---|
126 |
|
---|
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 |
|
---|
141 | my %i = caller_info($i);
|
---|
142 | $mess = "$err at $i{file} line $i{line}$tid_msg\n";
|
---|
143 |
|
---|
144 | while (my %i = caller_info(++$i)) {
|
---|
145 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
|
---|
146 | }
|
---|
147 |
|
---|
148 | return $mess;
|
---|
149 | }
|
---|
150 |
|
---|
151 | sub ret_summary {
|
---|
152 | my ($i, @error) = @_;
|
---|
153 | my $err = join '', @error;
|
---|
154 | $i++;
|
---|
155 |
|
---|
156 | my $tid_msg = '';
|
---|
157 | if (defined &Thread::tid) {
|
---|
158 | my $tid = Thread->self->tid;
|
---|
159 | $tid_msg = " thread $tid" if $tid;
|
---|
160 | }
|
---|
161 |
|
---|
162 | my %i = caller_info($i);
|
---|
163 | return "$err at $i{file} line $i{line}$tid_msg\n";
|
---|
164 | }
|
---|
165 |
|
---|
166 |
|
---|
167 | sub 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;
|
---|
182 | }
|
---|
183 |
|
---|
184 | sub shortmess_heavy {
|
---|
185 | return longmess_heavy(@_) if $Verbose;
|
---|
186 | return @_ if ref($_[0]); # don't break references as exceptions
|
---|
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 ...
|
---|
197 | sub 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 | }
|
---|
205 |
|
---|
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.
|
---|
212 | sub 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;
|
---|
226 | }
|
---|
227 | return exists $known->{$parent};
|
---|
228 | }
|
---|
229 |
|
---|
230 | # Takes a package and gives a list of those trusted directly
|
---|
231 | sub trusts_directly {
|
---|
232 | my $class = shift;
|
---|
233 | no strict 'refs';
|
---|
234 | no warnings 'once';
|
---|
235 | return @{"$class\::CARP_NOT"}
|
---|
236 | ? @{"$class\::CARP_NOT"}
|
---|
237 | : @{"$class\::ISA"};
|
---|
238 | }
|
---|
239 |
|
---|
240 | 1;
|
---|
241 |
|
---|