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