Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | package Carp; |
2 | ||
f06db76b AD |
3 | =head1 NAME |
4 | ||
5 | carp - warn of errors (from perspective of caller) | |
6 | ||
7 | croak - die of errors (from perspective of caller) | |
8 | ||
9 | confess - die of errors with stack backtrace | |
10 | ||
11 | =head1 SYNOPSIS | |
12 | ||
13 | use Carp; | |
14 | croak "We're outta here!"; | |
15 | ||
16 | =head1 DESCRIPTION | |
17 | ||
18 | The Carp routines are useful in your own modules because | |
19 | they act like die() or warn(), but report where the error | |
20 | was in the code they were called from. Thus if you have a | |
21 | routine Foo() that has a carp() in it, then the carp() | |
22 | will report the error as occurring where Foo() was called, | |
23 | not where carp() was called. | |
24 | ||
25 | =cut | |
26 | ||
a0d0e21e LW |
27 | # This package implements handy routines for modules that wish to throw |
28 | # exceptions outside of the current package. | |
29 | ||
748a9306 | 30 | $CarpLevel = 0; # How many extra package levels to skip on carp. |
c07a80fd | 31 | $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. |
748a9306 | 32 | |
a0d0e21e LW |
33 | require Exporter; |
34 | @ISA = Exporter; | |
35 | @EXPORT = qw(confess croak carp); | |
36 | ||
37 | sub longmess { | |
38 | my $error = shift; | |
39 | my $mess = ""; | |
748a9306 | 40 | my $i = 1 + $CarpLevel; |
c07a80fd | 41 | my ($pack,$file,$line,$sub,$eval,$require); |
42 | while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) { | |
c1bce5d7 | 43 | if ($error =~ m/\n$/) { |
44 | $mess .= $error; | |
45 | } else { | |
c07a80fd | 46 | if (defined $eval) { |
47 | if ($require) { | |
48 | $sub = "require $eval"; | |
49 | } else { | |
50 | $eval =~ s/[\\\']/\\$&/g; | |
51 | if ($MaxEvalLen && length($eval) > $MaxEvalLen) { | |
52 | substr($eval,$MaxEvalLen) = '...'; | |
53 | } | |
54 | $sub = "eval '$eval'"; | |
55 | } | |
56 | } elsif ($sub eq '(eval)') { | |
57 | $sub = 'eval {...}'; | |
58 | } | |
c1bce5d7 | 59 | $mess .= "\t$sub " if $error eq "called"; |
60 | $mess .= "$error at $file line $line\n"; | |
61 | } | |
a0d0e21e LW |
62 | $error = "called"; |
63 | } | |
64 | $mess || $error; | |
65 | } | |
66 | ||
748a9306 LW |
67 | sub shortmess { # Short-circuit &longmess if called via multiple packages |
68 | my $error = $_[0]; # Instead of "shift" | |
a0d0e21e | 69 | my ($curpack) = caller(1); |
748a9306 | 70 | my $extra = $CarpLevel; |
a0d0e21e | 71 | my $i = 2; |
c07a80fd | 72 | my ($pack,$file,$line); |
73 | while (($pack,$file,$line) = caller($i++)) { | |
748a9306 LW |
74 | if ($pack ne $curpack) { |
75 | if ($extra-- > 0) { | |
76 | $curpack = $pack; | |
77 | } | |
78 | else { | |
79 | return "$error at $file line $line\n"; | |
80 | } | |
81 | } | |
a0d0e21e | 82 | } |
748a9306 | 83 | goto &longmess; |
a0d0e21e LW |
84 | } |
85 | ||
86 | sub confess { die longmess @_; } | |
87 | sub croak { die shortmess @_; } | |
88 | sub carp { warn shortmess @_; } | |
89 | ||
748a9306 | 90 | 1; |