This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
remove outdated kludge in Carp (NULLs are permitted in diagnostics now)
[perl5.git] / lib / Carp / Heavy.pm
CommitLineData
3b5ca523 1package Carp;
ca24dfc6
LV
2
3=head1 NAME
4
5Carp::Heavy - Carp guts
6
7=head1 SYNOPIS
8
9(internal use only)
10
11=head1 DESCRIPTION
12
13No user-serviceable parts inside.
3cb6de81 14
ca24dfc6
LV
15=cut
16
3b5ca523
GS
17# This package is heavily used. Be small. Be fast. Be good.
18
19# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
20# _almost_ complete understanding of the package. Corrections and
21# comments are welcome.
22
23# longmess() crawls all the way up the stack reporting on all the function
24# calls made. The error string, $error, is originally constructed from the
25# arguments passed into longmess() via confess(), cluck() or shortmess().
26# This gets appended with the stack trace messages which are generated for
27# each function call on the stack.
28
29sub longmess_heavy {
30 return @_ if ref $_[0];
31 my $error = join '', @_;
32 my $mess = "";
33 my $i = 1 + $CarpLevel;
34 my ($pack,$file,$line,$sub,$hargs,$eval,$require);
35 my (@a);
36 #
37 # crawl up the stack....
38 #
39 while (do { { package DB; @a = caller($i++) } } ) {
40 # get copies of the variables returned from caller()
41 ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
42 #
43 # if the $error error string is newline terminated then it
44 # is copied into $mess. Otherwise, $mess gets set (at the end of
0aa0096c 45 # the 'else' section below) to one of two things. The first time
3b5ca523
GS
46 # through, it is set to the "$error at $file line $line" message.
47 # $error is then set to 'called' which triggers subsequent loop
48 # iterations to append $sub to $mess before appending the "$error
49 # at $file line $line" which now actually reads "called at $file line
50 # $line". Thus, the stack trace message is constructed:
51 #
52 # first time: $mess = $error at $file line $line
53 # subsequent times: $mess .= $sub $error at $file line $line
54 # ^^^^^^
55 # "called"
56 if ($error =~ m/\n$/) {
57 $mess .= $error;
58 } else {
59 # Build a string, $sub, which names the sub-routine called.
60 # This may also be "require ...", "eval '...' or "eval {...}"
61 if (defined $eval) {
62 if ($require) {
63 $sub = "require $eval";
64 } else {
65 $eval =~ s/([\\\'])/\\$1/g;
66 if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
67 substr($eval,$MaxEvalLen) = '...';
68 }
69 $sub = "eval '$eval'";
70 }
71 } elsif ($sub eq '(eval)') {
72 $sub = 'eval {...}';
73 }
74 # if there are any arguments in the sub-routine call, format
75 # them according to the format variables defined earlier in
76 # this file and join them onto the $sub sub-routine string
77 if ($hargs) {
78 # we may trash some of the args so we take a copy
79 @a = @DB::args; # must get local copy of args
80 # don't print any more than $MaxArgNums
81 if ($MaxArgNums and @a > $MaxArgNums) {
82 # cap the length of $#a and set the last element to '...'
83 $#a = $MaxArgNums;
84 $a[$#a] = "...";
85 }
86 for (@a) {
87 # set args to the string "undef" if undefined
88 $_ = "undef", next unless defined $_;
89 if (ref $_) {
191f2cf3 90 # force reference to string representation
3b5ca523
GS
91 $_ .= '';
92 s/'/\\'/g;
93 }
94 else {
95 s/'/\\'/g;
96 # terminate the string early with '...' if too long
97 substr($_,$MaxArgLen) = '...'
98 if $MaxArgLen and $MaxArgLen < length;
99 }
100 # 'quote' arg unless it looks like a number
101 $_ = "'$_'" unless /^-?[\d.]+$/;
102 # print high-end chars as 'M-<char>'
103 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
104 # print remaining control chars as ^<char>
105 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
106 }
107 # append ('all', 'the', 'arguments') to the $sub string
108 $sub .= '(' . join(', ', @a) . ')';
109 }
110 # here's where the error message, $mess, gets constructed
111 $mess .= "\t$sub " if $error eq "called";
112 $mess .= "$error at $file line $line";
1db3cb89 113 if (defined &Thread::tid) {
3b5ca523
GS
114 my $tid = Thread->self->tid;
115 $mess .= " thread $tid" if $tid;
116 }
117 $mess .= "\n";
118 }
119 # we don't need to print the actual error message again so we can
120 # change this to "called" so that the string "$error at $file line
121 # $line" makes sense as "called at $file line $line".
122 $error = "called";
123 }
0aa0096c 124 $mess || $error;
3b5ca523
GS
125}
126
127
191f2cf3
GS
128# ancestors() returns the complete set of ancestors of a module
129
d61e7a0a
GS
130sub ancestors($$);
131
191f2cf3
GS
132sub ancestors($$){
133 my( $pack, $href ) = @_;
134 if( @{"${pack}::ISA"} ){
135 my $risa = \@{"${pack}::ISA"};
136 my %tree = ();
137 @tree{@$risa} = ();
138 foreach my $mod ( @$risa ){
139 # visit ancestors - if not already in the gallery
140 if( ! defined( $$href{$mod} ) ){
141 my @ancs = ancestors( $mod, $href );
142 @tree{@ancs} = ();
143 }
144 }
145 return ( keys( %tree ) );
146 } else {
147 return ();
148 }
149}
150
151
3b5ca523
GS
152# shortmess() is called by carp() and croak() to skip all the way up to
153# the top-level caller's package and report the error from there. confess()
154# and cluck() generate a full stack trace so they call longmess() to
155# generate that. In verbose mode shortmess() calls longmess() so
156# you always get a stack trace
157
158sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages
159 goto &longmess_heavy if $Verbose;
160 return @_ if ref $_[0];
161 my $error = join '', @_;
162 my ($prevpack) = caller(1);
163 my $extra = $CarpLevel;
191f2cf3
GS
164
165 my @Clans = ( $prevpack );
3b5ca523
GS
166 my $i = 2;
167 my ($pack,$file,$line);
168 # when reporting an error, we want to report it from the context of the
169 # calling package. So what is the calling package? Within a module,
170 # there may be many calls between methods and perhaps between sub-classes
171 # and super-classes, but the user isn't interested in what happens
172 # inside the package. We start by building a hash array which keeps
173 # track of all the packages to which the calling package belongs. We
174 # do this by examining its @ISA variable. Any call from a base class
175 # method (one of our caller's @ISA packages) can be ignored
191f2cf3 176 my %isa;
3b5ca523 177
191f2cf3
GS
178 # merge all the caller's @ISA packages and ancestors into %isa.
179 my @pars = ancestors( $prevpack, \%isa );
180 @isa{@pars} = () if @pars;
181 $isa{$prevpack} = 1;
3b5ca523
GS
182
183 # now we crawl up the calling stack and look at all the packages in
184 # there. For each package, we look to see if it has an @ISA and then
185 # we see if our caller features in that list. That would imply that
186 # our caller is a derived class of that package and its calls can also
187 # be ignored
191f2cf3 188CALLER:
3b5ca523 189 while (($pack,$file,$line) = caller($i++)) {
3b5ca523 190
191f2cf3
GS
191 # Chances are, the caller's caller (or its caller...) is already
192 # in the gallery - if so, ignore this caller.
193 next if exists( $isa{$pack} );
194
195 # no: collect this module's ancestors.
196 my @i = ancestors( $pack, \%isa );
197 my %i;
198 if( @i ){
199 @i{@i} = ();
200 # check whether our representative of one of the clans is
201 # in this family tree.
202 foreach my $cl (@Clans){
203 if( exists( $i{$cl} ) ){
204 # yes: merge all of the family tree into %isa
205 @isa{@i,$pack} = ();
206 # and here's where we do some more ignoring...
207 # if the package in question is one of our caller's
208 # base or derived packages then we can ignore it (skip it)
209 # and go onto the next.
210 next CALLER if exists( $isa{$pack} );
211 last;
212 }
213 }
214 }
3b5ca523
GS
215
216 # Hey! We've found a package that isn't one of our caller's
217 # clan....but wait, $extra refers to the number of 'extra' levels
218 # we should skip up. If $extra > 0 then this is a false alarm.
219 # We must merge the package into the %isa hash (so we can ignore it
220 # if it pops up again), decrement $extra, and continue.
221 if ($extra-- > 0) {
191f2cf3
GS
222 push( @Clans, $pack );
223 @isa{@i,$pack} = ();
3b5ca523
GS
224 }
225 else {
226 # OK! We've got a candidate package. Time to construct the
0aa0096c 227 # relevant error message and return it.
3b5ca523
GS
228 my $msg;
229 $msg = "$error at $file line $line";
1db3cb89 230 if (defined &Thread::tid) {
3b5ca523
GS
231 my $tid = Thread->self->tid;
232 $mess .= " thread $tid" if $tid;
233 }
234 $msg .= "\n";
3b5ca523
GS
235 return $msg;
236 }
237 }
3b5ca523
GS
238
239 # uh-oh! It looks like we crawled all the way up the stack and
240 # never found a candidate package. Oh well, let's call longmess
241 # to generate a full stack trace. We use the magical form of 'goto'
242 # so that this shortmess() function doesn't appear on the stack
243 # to further confuse longmess() about it's calling package.
244 goto &longmess_heavy;
245}
246
2471;