This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[win32] integrate mainline
[perl5.git] / lib / Carp.pm
CommitLineData
a0d0e21e
LW
1package Carp;
2
f06db76b
AD
3=head1 NAME
4
4d935a29 5carp - warn of errors (from perspective of caller)
f06db76b 6
4d935a29
TB
7cluck - warn of errors with stack backtrace
8 (not exported by default)
9
10croak - die of errors (from perspective of caller)
f06db76b
AD
11
12confess - die of errors with stack backtrace
13
14=head1 SYNOPSIS
15
16 use Carp;
17 croak "We're outta here!";
18
4d935a29
TB
19 use Carp qw(cluck);
20 cluck "This is how we got here!";
21
f06db76b
AD
22=head1 DESCRIPTION
23
24The Carp routines are useful in your own modules because
25they act like die() or warn(), but report where the error
26was in the code they were called from. Thus if you have a
27routine Foo() that has a carp() in it, then the carp()
28will report the error as occurring where Foo() was called,
29not where carp() was called.
30
4d935a29
TB
31=head2 Forcing a Stack Trace
32
33As a debugging aid, you can force Carp to treat a croak as a confess
34and a carp as a cluck across I<all> modules. In other words, force a
35detailed stack trace to be given. This can be very helpful when trying
36to understand why, or from where, a warning or error is being generated.
37
38This feature is enabled by 'importing' the non-existant symbol
39'verbose'. You would typically enable it by saying
40
41 perl -MCarp=verbose script.pl
42
43or by including the string C<MCarp=verbose> in the L<PERL5OPT>
44environment variable.
45
f06db76b
AD
46=cut
47
4d935a29 48# This package is heavily used. Be small. Be fast. Be good.
a0d0e21e 49
748a9306 50$CarpLevel = 0; # How many extra package levels to skip on carp.
c07a80fd 51$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
55497cff
PP
52$MaxArgLen = 64; # How much of each argument to print. 0 = all.
53$MaxArgNums = 8; # How many arguments to print. 0 = all.
748a9306 54
a0d0e21e 55require Exporter;
fb73857a 56@ISA = ('Exporter');
a0d0e21e 57@EXPORT = qw(confess croak carp);
4d935a29
TB
58@EXPORT_OK = qw(cluck verbose);
59@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
60
61sub export_fail {
62 shift;
63 if ($_[0] eq 'verbose') {
64 local $^W = 0;
65 *shortmess = \&longmess;
66 shift;
67 }
68 return @_;
69}
70
a0d0e21e
LW
71
72sub longmess {
d43563dd 73 my $error = join '', @_;
a0d0e21e 74 my $mess = "";
748a9306 75 my $i = 1 + $CarpLevel;
55497cff
PP
76 my ($pack,$file,$line,$sub,$hargs,$eval,$require);
77 my (@a);
78 while (do { { package DB; @a = caller($i++) } } ) {
79 ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
c1bce5d7
PP
80 if ($error =~ m/\n$/) {
81 $mess .= $error;
82 } else {
c07a80fd
PP
83 if (defined $eval) {
84 if ($require) {
85 $sub = "require $eval";
86 } else {
9c7d8621 87 $eval =~ s/([\\\'])/\\$1/g;
c07a80fd
PP
88 if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
89 substr($eval,$MaxEvalLen) = '...';
90 }
91 $sub = "eval '$eval'";
92 }
93 } elsif ($sub eq '(eval)') {
94 $sub = 'eval {...}';
95 }
55497cff
PP
96 if ($hargs) {
97 @a = @DB::args; # must get local copy of args
98 if ($MaxArgNums and @a > $MaxArgNums) {
99 $#a = $MaxArgNums;
100 $a[$#a] = "...";
101 }
102 for (@a) {
798567d1 103 $_ = "undef", next unless defined $_;
68dc0745
PP
104 if (ref $_) {
105 $_ .= '';
106 s/'/\\'/g;
107 }
108 else {
109 s/'/\\'/g;
110 substr($_,$MaxArgLen) = '...'
111 if $MaxArgLen and $MaxArgLen < length;
112 }
113 $_ = "'$_'" unless /^-?[\d.]+$/;
55497cff
PP
114 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
115 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
116 }
117 $sub .= '(' . join(', ', @a) . ')';
118 }
c1bce5d7
PP
119 $mess .= "\t$sub " if $error eq "called";
120 $mess .= "$error at $file line $line\n";
121 }
a0d0e21e
LW
122 $error = "called";
123 }
68dc0745
PP
124 # this kludge circumvents die's incorrect handling of NUL
125 my $msg = \($mess || $error);
126 $$msg =~ tr/\0//d;
127 $$msg;
a0d0e21e
LW
128}
129
748a9306 130sub shortmess { # Short-circuit &longmess if called via multiple packages
d43563dd 131 my $error = join '', @_;
9c7d8621 132 my ($prevpack) = caller(1);
748a9306 133 my $extra = $CarpLevel;
a0d0e21e 134 my $i = 2;
c07a80fd 135 my ($pack,$file,$line);
9c7d8621
PP
136 my %isa = ($prevpack,1);
137
138 @isa{@{"${prevpack}::ISA"}} = ()
139 if(defined @{"${prevpack}::ISA"});
140
c07a80fd 141 while (($pack,$file,$line) = caller($i++)) {
9c7d8621
PP
142 if(defined @{$pack . "::ISA"}) {
143 my @i = @{$pack . "::ISA"};
144 my %i;
145 @i{@i} = ();
146 @isa{@i,$pack} = ()
147 if(exists $i{$prevpack} || exists $isa{$pack});
148 }
149
150 next
151 if(exists $isa{$pack});
152
153 if ($extra-- > 0) {
154 %isa = ($pack,1);
155 @isa{@{$pack . "::ISA"}} = ()
156 if(defined @{$pack . "::ISA"});
157 }
158 else {
68dc0745
PP
159 # this kludge circumvents die's incorrect handling of NUL
160 (my $msg = "$error at $file line $line\n") =~ tr/\0//d;
161 return $msg;
748a9306 162 }
a0d0e21e 163 }
9c7d8621
PP
164 continue {
165 $prevpack = $pack;
166 }
167
748a9306 168 goto &longmess;
a0d0e21e
LW
169}
170
171sub confess { die longmess @_; }
172sub croak { die shortmess @_; }
173sub carp { warn shortmess @_; }
4d935a29 174sub cluck { warn longmess @_; }
a0d0e21e 175
748a9306 1761;