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