This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: Inline PI function
[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 $_;
55497cff
PP
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
PP
79 $mess .= "\t$sub " if $error eq "called";
80 $mess .= "$error at $file line $line\n";
81 }
a0d0e21e
LW
82 $error = "called";
83 }
84 $mess || $error;
85}
86
748a9306 87sub shortmess { # Short-circuit &longmess if called via multiple packages
d43563dd 88 my $error = join '', @_;
9c7d8621 89 my ($prevpack) = caller(1);
748a9306 90 my $extra = $CarpLevel;
a0d0e21e 91 my $i = 2;
c07a80fd 92 my ($pack,$file,$line);
9c7d8621
PP
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
PP
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
PP
119 continue {
120 $prevpack = $pack;
121 }
122
748a9306 123 goto &longmess;
a0d0e21e
LW
124}
125
126sub confess { die longmess @_; }
127sub croak { die shortmess @_; }
128sub carp { warn shortmess @_; }
129
748a9306 1301;