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