This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[dummy merge]
[perl5.git] / lib / Carp.pm
CommitLineData
a0d0e21e
LW
1package Carp;
2
f06db76b
AD
3=head1 NAME
4
5carp - warn of errors (from perspective of caller)
6
7croak - die of errors (from perspective of caller)
8
9confess - 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
18The Carp routines are useful in your own modules because
19they act like die() or warn(), but report where the error
20was in the code they were called from. Thus if you have a
21routine Foo() that has a carp() in it, then the carp()
22will report the error as occurring where Foo() was called,
23not 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.
55497cff
PP
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
LW
35require Exporter;
36@ISA = Exporter;
37@EXPORT = qw(confess croak carp);
38
39sub longmess {
d43563dd 40 my $error = join '', @_;
a0d0e21e 41 my $mess = "";
748a9306 42 my $i = 1 + $CarpLevel;
55497cff
PP
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
PP
47 if ($error =~ m/\n$/) {
48 $mess .= $error;
49 } else {
c07a80fd
PP
50 if (defined $eval) {
51 if ($require) {
52 $sub = "require $eval";
53 } else {
9c7d8621 54 $eval =~ s/([\\\'])/\\$1/g;
c07a80fd
PP
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
PP
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 $_;
68dc0745
PP
71 if (ref $_) {
72 $_ .= '';
73 s/'/\\'/g;
74 }
75 else {
76 s/'/\\'/g;
77 substr($_,$MaxArgLen) = '...'
78 if $MaxArgLen and $MaxArgLen < length;
79 }
80 $_ = "'$_'" unless /^-?[\d.]+$/;
55497cff
PP
81 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
82 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
83 }
84 $sub .= '(' . join(', ', @a) . ')';
85 }
c1bce5d7
PP
86 $mess .= "\t$sub " if $error eq "called";
87 $mess .= "$error at $file line $line\n";
88 }
a0d0e21e
LW
89 $error = "called";
90 }
68dc0745
PP
91 # this kludge circumvents die's incorrect handling of NUL
92 my $msg = \($mess || $error);
93 $$msg =~ tr/\0//d;
94 $$msg;
a0d0e21e
LW
95}
96
748a9306 97sub shortmess { # Short-circuit &longmess if called via multiple packages
d43563dd 98 my $error = join '', @_;
9c7d8621 99 my ($prevpack) = caller(1);
748a9306 100 my $extra = $CarpLevel;
a0d0e21e 101 my $i = 2;
c07a80fd 102 my ($pack,$file,$line);
9c7d8621
PP
103 my %isa = ($prevpack,1);
104
105 @isa{@{"${prevpack}::ISA"}} = ()
106 if(defined @{"${prevpack}::ISA"});
107
c07a80fd 108 while (($pack,$file,$line) = caller($i++)) {
9c7d8621
PP
109 if(defined @{$pack . "::ISA"}) {
110 my @i = @{$pack . "::ISA"};
111 my %i;
112 @i{@i} = ();
113 @isa{@i,$pack} = ()
114 if(exists $i{$prevpack} || exists $isa{$pack});
115 }
116
117 next
118 if(exists $isa{$pack});
119
120 if ($extra-- > 0) {
121 %isa = ($pack,1);
122 @isa{@{$pack . "::ISA"}} = ()
123 if(defined @{$pack . "::ISA"});
124 }
125 else {
68dc0745
PP
126 # this kludge circumvents die's incorrect handling of NUL
127 (my $msg = "$error at $file line $line\n") =~ tr/\0//d;
128 return $msg;
748a9306 129 }
a0d0e21e 130 }
9c7d8621
PP
131 continue {
132 $prevpack = $pack;
133 }
134
748a9306 135 goto &longmess;
a0d0e21e
LW
136}
137
138sub confess { die longmess @_; }
139sub croak { die shortmess @_; }
140sub carp { warn shortmess @_; }
141
748a9306 1421;