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
1 package Carp;
2
3 =head1 NAME
4
5 Carp::Heavy - Carp guts
6
7 =head1 SYNOPIS
8
9 (internal use only)
10
11 =head1 DESCRIPTION
12
13 No user-serviceable parts inside.
14
15 =cut
16
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
29 sub 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
45         # the 'else' section below) to one of two things.  The first time
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 $_) {
90                         # force reference to string representation
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";
113             if (defined &Thread::tid) {
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     }
124     $mess || $error;
125 }
126
127
128 # ancestors() returns the complete set of ancestors of a module
129
130 sub ancestors($$);
131
132 sub 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
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
158 sub 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;
164
165     my @Clans = ( $prevpack );
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
176     my %isa;
177
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;
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
188 CALLER:
189     while (($pack,$file,$line) = caller($i++)) {
190
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         }
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) {
222             push( @Clans, $pack );
223             @isa{@i,$pack} = ();
224         }
225         else {
226             # OK!  We've got a candidate package.  Time to construct the
227             # relevant error message and return it.
228             my $msg;
229             $msg = "$error at $file line $line";
230             if (defined &Thread::tid) {
231                 my $tid = Thread->self->tid;
232                 $mess .= " thread $tid" if $tid;
233             }
234             $msg .= "\n";
235             return $msg;
236         }
237     }
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
247 1;