More robust yacc/bison failure output handling.
[p5sagit/p5-mst-13.2.git] / lib / Carp.pm
CommitLineData
a0d0e21e 1package Carp;
2
f06db76b 3=head1 NAME
4
4d935a29 5carp - warn of errors (from perspective of caller)
f06db76b 6
4d935a29 7cluck - warn of errors with stack backtrace
8 (not exported by default)
9
10croak - die of errors (from perspective of caller)
f06db76b 11
12confess - die of errors with stack backtrace
13
14=head1 SYNOPSIS
15
16 use Carp;
17 croak "We're outta here!";
18
4d935a29 19 use Carp qw(cluck);
20 cluck "This is how we got here!";
21
f06db76b 22=head1 DESCRIPTION
23
24The Carp routines are useful in your own modules because
25they act like die() or warn(), but report where the error
26was in the code they were called from. Thus if you have a
27routine Foo() that has a carp() in it, then the carp()
28will report the error as occurring where Foo() was called,
29not where carp() was called.
30
4d935a29 31=head2 Forcing a Stack Trace
32
33As a debugging aid, you can force Carp to treat a croak as a confess
34and a carp as a cluck across I<all> modules. In other words, force a
35detailed stack trace to be given. This can be very helpful when trying
36to understand why, or from where, a warning or error is being generated.
37
38This feature is enabled by 'importing' the non-existant symbol
39'verbose'. You would typically enable it by saying
40
41 perl -MCarp=verbose script.pl
42
43or by including the string C<MCarp=verbose> in the L<PERL5OPT>
44environment variable.
45
f06db76b 46=cut
47
4d935a29 48# This package is heavily used. Be small. Be fast. Be good.
a0d0e21e 49
7b8d334a 50# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
51# _almost_ complete understanding of the package. Corrections and
52# comments are welcome.
53
54# The $CarpLevel variable can be set to "strip off" extra caller levels for
55# those times when Carp calls are buried inside other functions. The
56# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
57# text and function arguments should be formatted when printed.
58
748a9306 59$CarpLevel = 0; # How many extra package levels to skip on carp.
c07a80fd 60$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
55497cff 61$MaxArgLen = 64; # How much of each argument to print. 0 = all.
62$MaxArgNums = 8; # How many arguments to print. 0 = all.
6ff81951 63$Verbose = 0; # If true then make shortmess call longmess instead
748a9306 64
a0d0e21e 65require Exporter;
fb73857a 66@ISA = ('Exporter');
a0d0e21e 67@EXPORT = qw(confess croak carp);
4d935a29 68@EXPORT_OK = qw(cluck verbose);
69@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
70
7b8d334a 71
72# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
73# then the following method will be called by the Exporter which knows
74# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
75# 'verbose'.
76
4d935a29 77sub export_fail {
78 shift;
6ff81951 79 $Verbose = shift if $_[0] eq 'verbose';
4d935a29 80 return @_;
81}
82
a0d0e21e 83
7b8d334a 84# longmess() crawls all the way up the stack reporting on all the function
85# calls made. The error string, $error, is originally constructed from the
86# arguments passed into longmess() via confess(), cluck() or shortmess().
87# This gets appended with the stack trace messages which are generated for
88# each function call on the stack.
89
a0d0e21e 90sub longmess {
d43563dd 91 my $error = join '', @_;
a0d0e21e 92 my $mess = "";
748a9306 93 my $i = 1 + $CarpLevel;
55497cff 94 my ($pack,$file,$line,$sub,$hargs,$eval,$require);
95 my (@a);
7b8d334a 96 #
97 # crawl up the stack....
98 #
55497cff 99 while (do { { package DB; @a = caller($i++) } } ) {
7b8d334a 100 # get copies of the variables returned from caller()
101 ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
102 #
103 # if the $error error string is newline terminated then it
104 # is copied into $mess. Otherwise, $mess gets set (at the end of
105 # the 'else {' section below) to one of two things. The first time
106 # through, it is set to the "$error at $file line $line" message.
107 # $error is then set to 'called' which triggers subsequent loop
108 # iterations to append $sub to $mess before appending the "$error
109 # at $file line $line" which now actually reads "called at $file line
110 # $line". Thus, the stack trace message is constructed:
111 #
112 # first time: $mess = $error at $file line $line
113 # subsequent times: $mess .= $sub $error at $file line $line
114 # ^^^^^^
115 # "called"
c1bce5d7 116 if ($error =~ m/\n$/) {
117 $mess .= $error;
118 } else {
7b8d334a 119 # Build a string, $sub, which names the sub-routine called.
120 # This may also be "require ...", "eval '...' or "eval {...}"
c07a80fd 121 if (defined $eval) {
7b8d334a 122 if ($require) {
c07a80fd 123 $sub = "require $eval";
124 } else {
9c7d8621 125 $eval =~ s/([\\\'])/\\$1/g;
c07a80fd 126 if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
127 substr($eval,$MaxEvalLen) = '...';
128 }
129 $sub = "eval '$eval'";
130 }
131 } elsif ($sub eq '(eval)') {
132 $sub = 'eval {...}';
133 }
7b8d334a 134 # if there are any arguments in the sub-routine call, format
135 # them according to the format variables defined earlier in
136 # this file and join them onto the $sub sub-routine string
55497cff 137 if ($hargs) {
7b8d334a 138 # we may trash some of the args so we take a copy
139 @a = @DB::args; # must get local copy of args
140 # don't print any more than $MaxArgNums
141 if ($MaxArgNums and @a > $MaxArgNums) {
142 # cap the length of $#a and set the last element to '...'
143 $#a = $MaxArgNums;
144 $a[$#a] = "...";
68dc0745 145 }
7b8d334a 146 for (@a) {
147 # set args to the string "undef" if undefined
148 $_ = "undef", next unless defined $_;
149 if (ref $_) {
150 # dunno what this is for...
151 $_ .= '';
152 s/'/\\'/g;
153 }
154 else {
155 s/'/\\'/g;
156 # terminate the string early with '...' if too long
157 substr($_,$MaxArgLen) = '...'
158 if $MaxArgLen and $MaxArgLen < length;
159 }
160 # 'quote' arg unless it looks like a number
161 $_ = "'$_'" unless /^-?[\d.]+$/;
162 # print high-end chars as 'M-<char>' or '^<char>'
163 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
164 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
68dc0745 165 }
7b8d334a 166 # append ('all', 'the', 'arguments') to the $sub string
167 $sub .= '(' . join(', ', @a) . ')';
55497cff 168 }
7b8d334a 169 # here's where the error message, $mess, gets constructed
c1bce5d7 170 $mess .= "\t$sub " if $error eq "called";
171 $mess .= "$error at $file line $line\n";
172 }
7b8d334a 173 # we don't need to print the actual error message again so we can
174 # change this to "called" so that the string "$error at $file line
175 # $line" makes sense as "called at $file line $line".
a0d0e21e 176 $error = "called";
177 }
68dc0745 178 # this kludge circumvents die's incorrect handling of NUL
179 my $msg = \($mess || $error);
180 $$msg =~ tr/\0//d;
181 $$msg;
a0d0e21e 182}
183
7b8d334a 184
185# shortmess() is called by carp() and croak() to skip all the way up to
186# the top-level caller's package and report the error from there. confess()
187# and cluck() generate a full stack trace so they call longmess() to
6ff81951 188# generate that. In verbose mode shortmess() calls longmess() so
7b8d334a 189# you always get a stack trace
190
748a9306 191sub shortmess { # Short-circuit &longmess if called via multiple packages
6ff81951 192 goto &longmess if $Verbose;
d43563dd 193 my $error = join '', @_;
9c7d8621 194 my ($prevpack) = caller(1);
748a9306 195 my $extra = $CarpLevel;
a0d0e21e 196 my $i = 2;
c07a80fd 197 my ($pack,$file,$line);
7b8d334a 198 # when reporting an error, we want to report it from the context of the
199 # calling package. So what is the calling package? Within a module,
200 # there may be many calls between methods and perhaps between sub-classes
201 # and super-classes, but the user isn't interested in what happens
202 # inside the package. We start by building a hash array which keeps
203 # track of all the packages to which the calling package belongs. We
204 # do this by examining its @ISA variable. Any call from a base class
205 # method (one of our caller's @ISA packages) can be ignored
9c7d8621 206 my %isa = ($prevpack,1);
207
7b8d334a 208 # merge all the caller's @ISA packages into %isa.
9c7d8621 209 @isa{@{"${prevpack}::ISA"}} = ()
210 if(defined @{"${prevpack}::ISA"});
211
7b8d334a 212 # now we crawl up the calling stack and look at all the packages in
213 # there. For each package, we look to see if it has an @ISA and then
214 # we see if our caller features in that list. That would imply that
215 # our caller is a derived class of that package and its calls can also
216 # be ignored
c07a80fd 217 while (($pack,$file,$line) = caller($i++)) {
9c7d8621 218 if(defined @{$pack . "::ISA"}) {
219 my @i = @{$pack . "::ISA"};
220 my %i;
221 @i{@i} = ();
7b8d334a 222 # merge any relevant packages into %isa
9c7d8621 223 @isa{@i,$pack} = ()
224 if(exists $i{$prevpack} || exists $isa{$pack});
225 }
226
7b8d334a 227 # and here's where we do the ignoring... if the package in
228 # question is one of our caller's base or derived packages then
229 # we can ignore it (skip it) and go onto the next (but note that
230 # the continue { } block below gets called every time)
9c7d8621 231 next
232 if(exists $isa{$pack});
233
7b8d334a 234 # Hey! We've found a package that isn't one of our caller's
235 # clan....but wait, $extra refers to the number of 'extra' levels
236 # we should skip up. If $extra > 0 then this is a false alarm.
237 # We must merge the package into the %isa hash (so we can ignore it
238 # if it pops up again), decrement $extra, and continue.
9c7d8621 239 if ($extra-- > 0) {
240 %isa = ($pack,1);
241 @isa{@{$pack . "::ISA"}} = ()
242 if(defined @{$pack . "::ISA"});
243 }
244 else {
7b8d334a 245 # OK! We've got a candidate package. Time to construct the
246 # relevant error message and return it. die() doesn't like
247 # to be given NUL characters (which $msg may contain) so we
248 # remove them first.
68dc0745 249 (my $msg = "$error at $file line $line\n") =~ tr/\0//d;
250 return $msg;
748a9306 251 }
a0d0e21e 252 }
9c7d8621 253 continue {
254 $prevpack = $pack;
255 }
256
7b8d334a 257 # uh-oh! It looks like we crawled all the way up the stack and
258 # never found a candidate package. Oh well, let's call longmess
259 # to generate a full stack trace. We use the magical form of 'goto'
260 # so that this shortmess() function doesn't appear on the stack
261 # to further confuse longmess() about it's calling package.
748a9306 262 goto &longmess;
a0d0e21e 263}
264
7b8d334a 265
266# the following four functions call longmess() or shortmess() depending on
267# whether they should generate a full stack trace (confess() and cluck())
268# or simply report the caller's package (croak() and carp()), respectively.
269# confess() and croak() die, carp() and cluck() warn.
270
271sub croak { die shortmess @_ }
272sub confess { die longmess @_ }
273sub carp { warn shortmess @_ }
274sub cluck { warn longmess @_ }
a0d0e21e 275
748a9306 2761;