This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5228b9b3a9b598bd20efdda90669fdd3d676f2ec
[perl5.git] / lib / Carp / Heavy.pm
1 # Carp::Heavy uses some variables in common with Carp.
2 package Carp;
3
4 =head1 NAME
5
6 Carp 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, $MaxLenArg, $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 (not defined($arg)) {
47     $arg = 'undef';
48   }
49   elsif (ref($arg)) {
50       $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
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?
61   $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->{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 }
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   { if ($err =~ /\n$/) {        # extra block to localise $1 etc
142     $mess = $err;
143   }
144   else {
145     my %i = caller_info($i);
146     $mess = "$err at $i{file} line $i{line}$tid_msg\n";
147   }}
148
149   while (my %i = caller_info(++$i)) {
150       $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
151   }
152   
153   return $mess;
154 }
155
156 sub ret_summary {
157   my ($i, @error) = @_;
158   my $mess;
159   my $err = join '', @error;
160   $i++;
161
162   my $tid_msg = '';
163   if (defined &Thread::tid) {
164     my $tid = Thread->self->tid;
165     $tid_msg = " thread $tid" if $tid;
166   }
167
168   my %i = caller_info($i);
169   return "$err at $i{file} line $i{line}$tid_msg\n";
170 }
171
172
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;
188 }
189
190 sub shortmess_heavy {
191   return longmess_heavy(@_) if $Verbose;
192   return @_ if ref($_[0]); # don't break references as exceptions
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 }
211
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;
232     }
233     return exists $known->{$parent};
234 }
235
236 # Takes a package and gives a list of those trusted directly
237 sub trusts_directly {
238     my $class = shift;
239     no strict 'refs';
240     return @{"$class\::CARP_NOT"}
241       ? @{"$class\::CARP_NOT"}
242       : @{"$class\::ISA"};
243 }
244
245 1;
246