Upgrade to Pod-Simple-3.08
[perl.git] / lib / Carp.pm
1 package Carp;
2
3 our $VERSION = '1.12';
4
5 our $MaxEvalLen = 0;
6 our $Verbose    = 0;
7 our $CarpLevel  = 0;
8 our $MaxArgLen  = 64;   # How much of each argument to print. 0 = all.
9 our $MaxArgNums = 8;    # How many arguments to print. 0 = all.
10
11 require Exporter;
12 our @ISA = ('Exporter');
13 our @EXPORT = qw(confess croak carp);
14 our @EXPORT_OK = qw(cluck verbose longmess shortmess);
15 our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
16
17 # The members of %Internal are packages that are internal to perl.
18 # Carp will not report errors from within these packages if it
19 # can.  The members of %CarpInternal are internal to Perl's warning
20 # system.  Carp will not report errors from within these packages
21 # either, and will not report calls *to* these packages for carp and
22 # croak.  They replace $CarpLevel, which is deprecated.    The
23 # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
24 # text and function arguments should be formatted when printed.
25
26 # disable these by default, so they can live w/o require Carp
27 $CarpInternal{Carp}++;
28 $CarpInternal{warnings}++;
29 $Internal{Exporter}++;
30 $Internal{'Exporter::Heavy'}++;
31
32 # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
33 # then the following method will be called by the Exporter which knows
34 # to do this thanks to @EXPORT_FAIL, above.  $_[1] will contain the word
35 # 'verbose'.
36
37 sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
38
39 sub longmess {
40     # Icky backwards compatibility wrapper. :-(
41     #
42     # The story is that the original implementation hard-coded the
43     # number of call levels to go back, so calls to longmess were off
44     # by one.  Other code began calling longmess and expecting this
45     # behaviour, so the replacement has to emulate that behaviour.
46     my $call_pack = caller();
47     if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
48       return longmess_heavy(@_);
49     }
50     else {
51       local $CarpLevel = $CarpLevel + 1;
52       return longmess_heavy(@_);
53     }
54 };
55
56 sub shortmess {
57     # Icky backwards compatibility wrapper. :-(
58     local @CARP_NOT = caller();
59     shortmess_heavy(@_);
60 };
61
62 sub croak   { die  shortmess @_ }
63 sub confess { die  longmess  @_ }
64 sub carp    { warn shortmess @_ }
65 sub cluck   { warn longmess  @_ }
66
67 sub caller_info {
68   my $i = shift(@_) + 1;
69   package DB;
70   my %call_info;
71   @call_info{
72     qw(pack file line sub has_args wantarray evaltext is_require)
73   } = caller($i);
74   
75   unless (defined $call_info{pack}) {
76     return ();
77   }
78
79   my $sub_name = Carp::get_subname(\%call_info);
80   if ($call_info{has_args}) {
81     my @args = map {Carp::format_arg($_)} @DB::args;
82     if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
83       $#args = $MaxArgNums;
84       push @args, '...';
85     }
86     # Push the args onto the subroutine
87     $sub_name .= '(' . join (', ', @args) . ')';
88   }
89   $call_info{sub_name} = $sub_name;
90   return wantarray() ? %call_info : \%call_info;
91 }
92
93 # Transform an argument to a function into a string.
94 sub format_arg {
95   my $arg = shift;
96   if (ref($arg)) {
97       $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
98   }
99   if (defined($arg)) {
100       $arg =~ s/'/\\'/g;
101       $arg = str_len_trim($arg, $MaxArgLen);
102   
103       # Quote it?
104       $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
105   } else {
106       $arg = 'undef';
107   }
108
109   # The following handling of "control chars" is direct from
110   # the original code - it is broken on Unicode though.
111   # Suggestions?
112   utf8::is_utf8($arg)
113     or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
114   return $arg;
115 }
116
117 # Takes an inheritance cache and a package and returns
118 # an anon hash of known inheritances and anon array of
119 # inheritances which consequences have not been figured
120 # for.
121 sub get_status {
122     my $cache = shift;
123     my $pkg = shift;
124     $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
125     return @{$cache->{$pkg}};
126 }
127
128 # Takes the info from caller() and figures out the name of
129 # the sub/require/eval
130 sub get_subname {
131   my $info = shift;
132   if (defined($info->{evaltext})) {
133     my $eval = $info->{evaltext};
134     if ($info->{is_require}) {
135       return "require $eval";
136     }
137     else {
138       $eval =~ s/([\\\'])/\\$1/g;
139       return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
140     }
141   }
142
143   return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
144 }
145
146 # Figures out what call (from the point of view of the caller)
147 # the long error backtrace should start at.
148 sub long_error_loc {
149   my $i;
150   my $lvl = $CarpLevel;
151   {
152     my $pkg = caller(++$i);
153     unless(defined($pkg)) {
154       # This *shouldn't* happen.
155       if (%Internal) {
156         local %Internal;
157         $i = long_error_loc();
158         last;
159       }
160       else {
161         # OK, now I am irritated.
162         return 2;
163       }
164     }
165     redo if $CarpInternal{$pkg};
166     redo unless 0 > --$lvl;
167     redo if $Internal{$pkg};
168   }
169   return $i - 1;
170 }
171
172
173 sub longmess_heavy {
174   return @_ if ref($_[0]); # don't break references as exceptions
175   my $i = long_error_loc();
176   return ret_backtrace($i, @_);
177 }
178
179 # Returns a full stack backtrace starting from where it is
180 # told.
181 sub ret_backtrace {
182   my ($i, @error) = @_;
183   my $mess;
184   my $err = join '', @error;
185   $i++;
186
187   my $tid_msg = '';
188   if (defined &threads::tid) {
189     my $tid = threads->tid;
190     $tid_msg = " thread $tid" if $tid;
191   }
192
193   my %i = caller_info($i);
194   $mess = "$err at $i{file} line $i{line}$tid_msg\n";
195
196   while (my %i = caller_info(++$i)) {
197       $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
198   }
199   
200   return $mess;
201 }
202
203 sub ret_summary {
204   my ($i, @error) = @_;
205   my $err = join '', @error;
206   $i++;
207
208   my $tid_msg = '';
209   if (defined &threads::tid) {
210     my $tid = threads->tid;
211     $tid_msg = " thread $tid" if $tid;
212   }
213
214   my %i = caller_info($i);
215   return "$err at $i{file} line $i{line}$tid_msg\n";
216 }
217
218
219 sub short_error_loc {
220   # You have to create your (hash)ref out here, rather than defaulting it
221   # inside trusts *on a lexical*, as you want it to persist across calls.
222   # (You can default it on $_[2], but that gets messy)
223   my $cache = {};
224   my $i = 1;
225   my $lvl = $CarpLevel;
226   {
227     my $called = caller($i++);
228     my $caller = caller($i);
229
230     return 0 unless defined($caller); # What happened?
231     redo if $Internal{$caller};
232     redo if $CarpInternal{$caller};
233     redo if $CarpInternal{$called};
234     redo if trusts($called, $caller, $cache);
235     redo if trusts($caller, $called, $cache);
236     redo unless 0 > --$lvl;
237   }
238   return $i - 1;
239 }
240
241
242 sub shortmess_heavy {
243   return longmess_heavy(@_) if $Verbose;
244   return @_ if ref($_[0]); # don't break references as exceptions
245   my $i = short_error_loc();
246   if ($i) {
247     ret_summary($i, @_);
248   }
249   else {
250     longmess_heavy(@_);
251   }
252 }
253
254 # If a string is too long, trims it with ...
255 sub str_len_trim {
256   my $str = shift;
257   my $max = shift || 0;
258   if (2 < $max and $max < length($str)) {
259     substr($str, $max - 3) = '...';
260   }
261   return $str;
262 }
263
264 # Takes two packages and an optional cache.  Says whether the
265 # first inherits from the second.
266 #
267 # Recursive versions of this have to work to avoid certain
268 # possible endless loops, and when following long chains of
269 # inheritance are less efficient.
270 sub trusts {
271     my $child = shift;
272     my $parent = shift;
273     my $cache = shift;
274     my ($known, $partial) = get_status($cache, $child);
275     # Figure out consequences until we have an answer
276     while (@$partial and not exists $known->{$parent}) {
277         my $anc = shift @$partial;
278         next if exists $known->{$anc};
279         $known->{$anc}++;
280         my ($anc_knows, $anc_partial) = get_status($cache, $anc);
281         my @found = keys %$anc_knows;
282         @$known{@found} = ();
283         push @$partial, @$anc_partial;
284     }
285     return exists $known->{$parent};
286 }
287
288 # Takes a package and gives a list of those trusted directly
289 sub trusts_directly {
290     my $class = shift;
291     no strict 'refs';
292     no warnings 'once'; 
293     return @{"$class\::CARP_NOT"}
294       ? @{"$class\::CARP_NOT"}
295       : @{"$class\::ISA"};
296 }
297
298 1;
299
300 __END__
301
302 =head1 NAME
303
304 carp    - warn of errors (from perspective of caller)
305
306 cluck   - warn of errors with stack backtrace
307           (not exported by default)
308
309 croak   - die of errors (from perspective of caller)
310
311 confess - die of errors with stack backtrace
312
313 =head1 SYNOPSIS
314
315     use Carp;
316     croak "We're outta here!";
317
318     use Carp qw(cluck);
319     cluck "This is how we got here!";
320
321 =head1 DESCRIPTION
322
323 The Carp routines are useful in your own modules because
324 they act like die() or warn(), but with a message which is more
325 likely to be useful to a user of your module.  In the case of
326 cluck, confess, and longmess that context is a summary of every
327 call in the call-stack.  For a shorter message you can use C<carp>
328 or C<croak> which report the error as being from where your module
329 was called.  There is no guarantee that that is where the error
330 was, but it is a good educated guess.
331
332 You can also alter the way the output and logic of C<Carp> works, by
333 changing some global variables in the C<Carp> namespace. See the
334 section on C<GLOBAL VARIABLES> below.
335
336 Here is a more complete description of how C<carp> and C<croak> work.
337 What they do is search the call-stack for a function call stack where
338 they have not been told that there shouldn't be an error.  If every
339 call is marked safe, they give up and give a full stack backtrace
340 instead.  In other words they presume that the first likely looking
341 potential suspect is guilty.  Their rules for telling whether
342 a call shouldn't generate errors work as follows:
343
344 =over 4
345
346 =item 1.
347
348 Any call from a package to itself is safe.
349
350 =item 2.
351
352 Packages claim that there won't be errors on calls to or from
353 packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
354 (if that array is empty) C<@ISA>.  The ability to override what
355 @ISA says is new in 5.8.
356
357 =item 3.
358
359 The trust in item 2 is transitive.  If A trusts B, and B
360 trusts C, then A trusts C.  So if you do not override C<@ISA>
361 with C<@CARP_NOT>, then this trust relationship is identical to,
362 "inherits from".
363
364 =item 4.
365
366 Any call from an internal Perl module is safe.  (Nothing keeps
367 user modules from marking themselves as internal to Perl, but
368 this practice is discouraged.)
369
370 =item 5.
371
372 Any call to Perl's warning system (eg Carp itself) is safe.
373 (This rule is what keeps it from reporting the error at the
374 point where you call C<carp> or C<croak>.)
375
376 =item 6.
377
378 C<$Carp::CarpLevel> can be set to skip a fixed number of additional
379 call levels.  Using this is not recommended because it is very
380 difficult to get it to behave correctly.
381
382 =back
383
384 =head2 Forcing a Stack Trace
385
386 As a debugging aid, you can force Carp to treat a croak as a confess
387 and a carp as a cluck across I<all> modules. In other words, force a
388 detailed stack trace to be given.  This can be very helpful when trying
389 to understand why, or from where, a warning or error is being generated.
390
391 This feature is enabled by 'importing' the non-existent symbol
392 'verbose'. You would typically enable it by saying
393
394     perl -MCarp=verbose script.pl
395
396 or by including the string C<-MCarp=verbose> in the PERL5OPT
397 environment variable.
398
399 Alternately, you can set the global variable C<$Carp::Verbose> to true.
400 See the C<GLOBAL VARIABLES> section below.
401
402 =head1 GLOBAL VARIABLES
403
404 =head2 $Carp::MaxEvalLen
405
406 This variable determines how many characters of a string-eval are to
407 be shown in the output. Use a value of C<0> to show all text.
408
409 Defaults to C<0>.
410
411 =head2 $Carp::MaxArgLen
412
413 This variable determines how many characters of each argument to a
414 function to print. Use a value of C<0> to show the full length of the
415 argument.
416
417 Defaults to C<64>.
418
419 =head2 $Carp::MaxArgNums
420
421 This variable determines how many arguments to each function to show.
422 Use a value of C<0> to show all arguments to a function call.
423
424 Defaults to C<8>.
425
426 =head2 $Carp::Verbose
427
428 This variable makes C<carp> and C<cluck> generate stack backtraces
429 just like C<cluck> and C<confess>.  This is how C<use Carp 'verbose'>
430 is implemented internally.
431
432 Defaults to C<0>.
433
434 =head2 @CARP_NOT
435
436 This variable, I<in your package>, says which packages are I<not> to be
437 considered as the location of an error. The C<carp()> and C<cluck()>
438 functions will skip over callers when reporting where an error occurred.
439
440 NB: This variable must be in the package's symbol table, thus:
441
442     # These work
443     our @CARP_NOT; # file scope
444     use vars qw(@CARP_NOT); # package scope
445     @My::Package::CARP_NOT = ... ; # explicit package variable
446
447     # These don't work
448     sub xyz { ... @CARP_NOT = ... } # w/o declarations above
449     my @CARP_NOT; # even at top-level
450
451 Example of use:
452
453     package My::Carping::Package;
454     use Carp;
455     our @CARP_NOT;
456     sub bar     { .... or _error('Wrong input') }
457     sub _error  {
458         # temporary control of where'ness, __PACKAGE__ is implicit
459         local @CARP_NOT = qw(My::Friendly::Caller);
460         carp(@_)
461     }
462
463 This would make C<Carp> report the error as coming from a caller not
464 in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
465
466 Also read the L</DESCRIPTION> section above, about how C<Carp> decides
467 where the error is reported from.
468
469 Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
470
471 Overrides C<Carp>'s use of C<@ISA>.
472
473 =head2 %Carp::Internal
474
475 This says what packages are internal to Perl.  C<Carp> will never
476 report an error as being from a line in a package that is internal to
477 Perl.  For example:
478
479     $Carp::Internal{ (__PACKAGE__) }++;
480     # time passes...
481     sub foo { ... or confess("whatever") };
482
483 would give a full stack backtrace starting from the first caller
484 outside of __PACKAGE__.  (Unless that package was also internal to
485 Perl.)
486
487 =head2 %Carp::CarpInternal
488
489 This says which packages are internal to Perl's warning system.  For
490 generating a full stack backtrace this is the same as being internal
491 to Perl, the stack backtrace will not start inside packages that are
492 listed in C<%Carp::CarpInternal>.  But it is slightly different for
493 the summary message generated by C<carp> or C<croak>.  There errors
494 will not be reported on any lines that are calling packages in
495 C<%Carp::CarpInternal>.
496
497 For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
498 Therefore the full stack backtrace from C<confess> will not start
499 inside of C<Carp>, and the short message from calling C<croak> is
500 not placed on the line where C<croak> was called.
501
502 =head2 $Carp::CarpLevel
503
504 This variable determines how many additional call frames are to be
505 skipped that would not otherwise be when reporting where an error
506 occurred on a call to one of C<Carp>'s functions.  It is fairly easy
507 to count these call frames on calls that generate a full stack
508 backtrace.  However it is much harder to do this accounting for calls
509 that generate a short message.  Usually people skip too many call
510 frames.  If they are lucky they skip enough that C<Carp> goes all of
511 the way through the call stack, realizes that something is wrong, and
512 then generates a full stack backtrace.  If they are unlucky then the
513 error is reported from somewhere misleading very high in the call
514 stack.
515
516 Therefore it is best to avoid C<$Carp::CarpLevel>.  Instead use
517 C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
518
519 Defaults to C<0>.
520
521 =head1 BUGS
522
523 The Carp routines don't handle exception objects currently.
524 If called with a first argument that is a reference, they simply
525 call die() or warn(), as appropriate.
526