perl5.002beta3
[perl.git] / lib / Carp.pm
1 package Carp;
2
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
27 # This package implements handy routines for modules that wish to throw
28 # exceptions outside of the current package.
29
30 $CarpLevel = 0;         # How many extra package levels to skip on carp.
31 $MaxEvalLen = 0;        # How much eval '...text...' to show. 0 = all.
32
33 require Exporter;
34 @ISA = Exporter;
35 @EXPORT = qw(confess croak carp);
36
37 sub longmess {
38     my $error = shift;
39     my $mess = "";
40     my $i = 1 + $CarpLevel;
41     my ($pack,$file,$line,$sub,$eval,$require);
42     while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) {
43         if ($error =~ m/\n$/) {
44             $mess .= $error;
45         } else {
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             }
59             $mess .= "\t$sub " if $error eq "called";
60             $mess .= "$error at $file line $line\n";
61         }
62         $error = "called";
63     }
64     $mess || $error;
65 }
66
67 sub shortmess { # Short-circuit &longmess if called via multiple packages
68     my $error = $_[0];  # Instead of "shift"
69     my ($curpack) = caller(1);
70     my $extra = $CarpLevel;
71     my $i = 2;
72     my ($pack,$file,$line);
73     while (($pack,$file,$line) = caller($i++)) {
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         }
82     }
83     goto &longmess;
84 }
85
86 sub confess { die longmess @_; }
87 sub croak { die shortmess @_; }
88 sub carp { warn shortmess @_; }
89
90 1;