Commit | Line | Data |
a0d0e21e |
1 | package Carp; |
2 | |
f06db76b |
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 |
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. |
55497cff |
32 | $MaxArgLen = 64; # How much of each argument to print. 0 = all. |
33 | $MaxArgNums = 8; # How many arguments to print. 0 = all. |
748a9306 |
34 | |
a0d0e21e |
35 | require Exporter; |
36 | @ISA = Exporter; |
37 | @EXPORT = qw(confess croak carp); |
38 | |
39 | sub longmess { |
40 | my $error = shift; |
41 | my $mess = ""; |
748a9306 |
42 | my $i = 1 + $CarpLevel; |
55497cff |
43 | my ($pack,$file,$line,$sub,$hargs,$eval,$require); |
44 | my (@a); |
45 | while (do { { package DB; @a = caller($i++) } } ) { |
46 | ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; |
c1bce5d7 |
47 | if ($error =~ m/\n$/) { |
48 | $mess .= $error; |
49 | } else { |
c07a80fd |
50 | if (defined $eval) { |
51 | if ($require) { |
52 | $sub = "require $eval"; |
53 | } else { |
9c7d8621 |
54 | $eval =~ s/([\\\'])/\\$1/g; |
c07a80fd |
55 | if ($MaxEvalLen && length($eval) > $MaxEvalLen) { |
56 | substr($eval,$MaxEvalLen) = '...'; |
57 | } |
58 | $sub = "eval '$eval'"; |
59 | } |
60 | } elsif ($sub eq '(eval)') { |
61 | $sub = 'eval {...}'; |
62 | } |
55497cff |
63 | if ($hargs) { |
64 | @a = @DB::args; # must get local copy of args |
65 | if ($MaxArgNums and @a > $MaxArgNums) { |
66 | $#a = $MaxArgNums; |
67 | $a[$#a] = "..."; |
68 | } |
69 | for (@a) { |
798567d1 |
70 | $_ = "undef", next unless defined $_; |
55497cff |
71 | s/'/\\'/g; |
72 | substr($_,$MaxArgLen) = '...' if $MaxArgLen and $MaxArgLen < length; |
73 | s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; |
74 | s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; |
75 | s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; |
76 | } |
77 | $sub .= '(' . join(', ', @a) . ')'; |
78 | } |
c1bce5d7 |
79 | $mess .= "\t$sub " if $error eq "called"; |
80 | $mess .= "$error at $file line $line\n"; |
81 | } |
a0d0e21e |
82 | $error = "called"; |
83 | } |
84 | $mess || $error; |
85 | } |
86 | |
748a9306 |
87 | sub shortmess { # Short-circuit &longmess if called via multiple packages |
88 | my $error = $_[0]; # Instead of "shift" |
9c7d8621 |
89 | my ($prevpack) = caller(1); |
748a9306 |
90 | my $extra = $CarpLevel; |
a0d0e21e |
91 | my $i = 2; |
c07a80fd |
92 | my ($pack,$file,$line); |
9c7d8621 |
93 | my %isa = ($prevpack,1); |
94 | |
95 | @isa{@{"${prevpack}::ISA"}} = () |
96 | if(defined @{"${prevpack}::ISA"}); |
97 | |
c07a80fd |
98 | while (($pack,$file,$line) = caller($i++)) { |
9c7d8621 |
99 | if(defined @{$pack . "::ISA"}) { |
100 | my @i = @{$pack . "::ISA"}; |
101 | my %i; |
102 | @i{@i} = (); |
103 | @isa{@i,$pack} = () |
104 | if(exists $i{$prevpack} || exists $isa{$pack}); |
105 | } |
106 | |
107 | next |
108 | if(exists $isa{$pack}); |
109 | |
110 | if ($extra-- > 0) { |
111 | %isa = ($pack,1); |
112 | @isa{@{$pack . "::ISA"}} = () |
113 | if(defined @{$pack . "::ISA"}); |
114 | } |
115 | else { |
116 | return "$error at $file line $line\n"; |
748a9306 |
117 | } |
a0d0e21e |
118 | } |
9c7d8621 |
119 | continue { |
120 | $prevpack = $pack; |
121 | } |
122 | |
748a9306 |
123 | goto &longmess; |
a0d0e21e |
124 | } |
125 | |
126 | sub confess { die longmess @_; } |
127 | sub croak { die shortmess @_; } |
128 | sub carp { warn shortmess @_; } |
129 | |
748a9306 |
130 | 1; |