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