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