Commit | Line | Data |
a0d0e21e |
1 | package Carp; |
2 | |
f06db76b |
3 | =head1 NAME |
4 | |
4d935a29 |
5 | carp - warn of errors (from perspective of caller) |
f06db76b |
6 | |
4d935a29 |
7 | cluck - warn of errors with stack backtrace |
8 | (not exported by default) |
9 | |
10 | croak - die of errors (from perspective of caller) |
f06db76b |
11 | |
12 | confess - die of errors with stack backtrace |
13 | |
14 | =head1 SYNOPSIS |
15 | |
16 | use Carp; |
17 | croak "We're outta here!"; |
18 | |
4d935a29 |
19 | use Carp qw(cluck); |
20 | cluck "This is how we got here!"; |
21 | |
f06db76b |
22 | =head1 DESCRIPTION |
23 | |
24 | The Carp routines are useful in your own modules because |
25 | they act like die() or warn(), but report where the error |
26 | was in the code they were called from. Thus if you have a |
27 | routine Foo() that has a carp() in it, then the carp() |
28 | will report the error as occurring where Foo() was called, |
29 | not where carp() was called. |
30 | |
4d935a29 |
31 | =head2 Forcing a Stack Trace |
32 | |
33 | As a debugging aid, you can force Carp to treat a croak as a confess |
34 | and a carp as a cluck across I<all> modules. In other words, force a |
35 | detailed stack trace to be given. This can be very helpful when trying |
36 | to understand why, or from where, a warning or error is being generated. |
37 | |
38 | This 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 | |
43 | or by including the string C<MCarp=verbose> in the L<PERL5OPT> |
44 | environment variable. |
45 | |
f06db76b |
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 |
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 |
55 | require Exporter; |
fb73857a |
56 | @ISA = ('Exporter'); |
a0d0e21e |
57 | @EXPORT = qw(confess croak carp); |
4d935a29 |
58 | @EXPORT_OK = qw(cluck verbose); |
59 | @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode |
60 | |
61 | sub export_fail { |
62 | shift; |
63 | if ($_[0] eq 'verbose') { |
64 | local $^W = 0; |
65 | *shortmess = \&longmess; |
66 | shift; |
67 | } |
68 | return @_; |
69 | } |
70 | |
a0d0e21e |
71 | |
72 | sub longmess { |
d43563dd |
73 | my $error = join '', @_; |
a0d0e21e |
74 | my $mess = ""; |
748a9306 |
75 | my $i = 1 + $CarpLevel; |
55497cff |
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 |
80 | if ($error =~ m/\n$/) { |
81 | $mess .= $error; |
82 | } else { |
c07a80fd |
83 | if (defined $eval) { |
84 | if ($require) { |
85 | $sub = "require $eval"; |
86 | } else { |
9c7d8621 |
87 | $eval =~ s/([\\\'])/\\$1/g; |
c07a80fd |
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 |
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 |
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 |
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 |
119 | $mess .= "\t$sub " if $error eq "called"; |
120 | $mess .= "$error at $file line $line\n"; |
121 | } |
a0d0e21e |
122 | $error = "called"; |
123 | } |
68dc0745 |
124 | # this kludge circumvents die's incorrect handling of NUL |
125 | my $msg = \($mess || $error); |
126 | $$msg =~ tr/\0//d; |
127 | $$msg; |
a0d0e21e |
128 | } |
129 | |
748a9306 |
130 | sub 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 |
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 |
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 |
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 |
164 | continue { |
165 | $prevpack = $pack; |
166 | } |
167 | |
748a9306 |
168 | goto &longmess; |
a0d0e21e |
169 | } |
170 | |
171 | sub confess { die longmess @_; } |
172 | sub croak { die shortmess @_; } |
173 | sub carp { warn shortmess @_; } |
4d935a29 |
174 | sub cluck { warn longmess @_; } |
a0d0e21e |
175 | |
748a9306 |
176 | 1; |