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 $MaxArgLen = 64;        # How much of each argument to print. 0 = all.
  33 $MaxArgNums = 8;        # How many arguments to print. 0 = all.
  34
  35 require Exporter;
  36 @ISA = Exporter;
  37 @EXPORT = qw(confess croak carp);
  38
  39 sub longmess {
  40     my $error = join '', @_;
  41     my $mess = "";
  42     my $i = 1 + $CarpLevel;
  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;
  47         if ($error =~ m/\n$/) {
  48             $mess .= $error;
  49         } else {
  50             if (defined $eval) {
  51                 if ($require) {
  52                     $sub = "require $eval";
  53                 } else {
  54                     $eval =~ s/([\\\'])/\\$1/g;
  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             }
  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) {
  70                 $_ = "undef", next unless defined $_;
  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.]+$/;
  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             }
  86             $mess .= "\t$sub " if $error eq "called";
  87             $mess .= "$error at $file line $line\n";
  88         }
  89         $error = "called";
  90     }
  91     # this kludge circumvents die's incorrect handling of NUL
  92     my $msg = \($mess || $error);
  93     $$msg =~ tr/\0//d;
  94     $$msg;
  95 }
  96
  97 sub shortmess { # Short-circuit &longmess if called via multiple packages
  98     my $error = join '', @_;
  99     my ($prevpack) = caller(1);
 100     my $extra = $CarpLevel;
 101     my $i = 2;
 102     my ($pack,$file,$line);
 103     my %isa = ($prevpack,1);
 104
 105     @isa{@{"${prevpack}::ISA"}} = ()
 106         if(defined @{"${prevpack}::ISA"});
 107
 108     while (($pack,$file,$line) = caller($i++)) {
 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 {
 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;
 129         }
 130     }
 131     continue {
 132         $prevpack = $pack;
 133     }
 134
 135     goto &longmess;
 136 }
 137
 138 sub confess { die longmess @_; }
 139 sub croak { die shortmess @_; }
 140 sub carp { warn shortmess @_; }
 141
 142 1;