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