lib/Carp.pm

   1 package Carp;
   2
   3 =head1 NAME
   4
   5 carp    - warn of errors (from perspective of caller)
   6
   7 cluck   - warn of errors with stack backtrace
   8           (not exported by default)
   9
  10 croak   - die of errors (from perspective of caller)
  11
  12 confess - die of errors with stack backtrace
  13
  14 =head1 SYNOPSIS
  15
  16     use Carp;
  17     croak "We're outta here!";
  18
  19     use Carp qw(cluck);
  20     cluck "This is how we got here!";
  21
  22 =head1 DESCRIPTION
  23
  24 The Carp routines are useful in your own modules because
  25 they act like die() or warn(), but report where the error
  26 was in the code they were called from.  Thus if you have a
  27 routine Foo() that has a carp() in it, then the carp()
  28 will report the error as occurring where Foo() was called,
  29 not where carp() was called.
  30
  31 =head2 Forcing a Stack Trace
  32
  33 As a debugging aid, you can force Carp to treat a croak as a confess
  34 and a carp as a cluck across I<all> modules. In other words, force a
  35 detailed stack trace to be given.  This can be very helpful when trying
  36 to understand why, or from where, a warning or error is being generated.
  37
  38 This feature is enabled by 'importing' the non-existant symbol
  39 'verbose'. You would typically enable it by saying
  40
  41     perl -MCarp=verbose script.pl
  42
  43 or by including the string C<MCarp=verbose> in the L<PERL5OPT>
  44 environment variable.
  45
  46 =cut
  47
  48 # This package is heavily used. Be small. Be fast. Be good.
  49
  50 $CarpLevel = 0;         # How many extra package levels to skip on carp.
  51 $MaxEvalLen = 0;        # How much eval '...text...' to show. 0 = all.
  52 $MaxArgLen = 64;        # How much of each argument to print. 0 = all.
  53 $MaxArgNums = 8;        # How many arguments to print. 0 = all.
  54
  55 require Exporter;
  56 @ISA = ('Exporter');
  57 @EXPORT = qw(confess croak carp);
  58 @EXPORT_OK = qw(cluck verbose);
  59 @EXPORT_FAIL = qw(verbose);     # hook to enable verbose mode
  60
  61 sub export_fail {
  62     shift;
  63     if ($_[0] eq 'verbose') {
  64         local $^W = 0;
  65         *shortmess = \&longmess;
  66         shift;
  67     }
  68     return @_;
  69 }
  70
  71
  72 sub longmess {
  73     my $error = join '', @_;
  74     my $mess = "";
  75     my $i = 1 + $CarpLevel;
  76     my ($pack,$file,$line,$sub,$hargs,$eval,$require);
  77     my (@a);
  78     while (do { { package DB; @a = caller($i++) } } ) {
  79       ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
  80         if ($error =~ m/\n$/) {
  81             $mess .= $error;
  82         } else {
  83             if (defined $eval) {
  84                 if ($require) {
  85                     $sub = "require $eval";
  86                 } else {
  87                     $eval =~ s/([\\\'])/\\$1/g;
  88                     if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
  89                         substr($eval,$MaxEvalLen) = '...';
  90                     }
  91                     $sub = "eval '$eval'";
  92                 }
  93             } elsif ($sub eq '(eval)') {
  94                 $sub = 'eval {...}';
  95             }
  96             if ($hargs) {
  97               @a = @DB::args;   # must get local copy of args
  98               if ($MaxArgNums and @a > $MaxArgNums) {
  99                 $#a = $MaxArgNums;
 100                 $a[$#a] = "...";
 101               }
 102               for (@a) {
 103                 $_ = "undef", next unless defined $_;
 104                 if (ref $_) {
 105                   $_ .= '';
 106                   s/'/\\'/g;
 107                 }
 108                 else {
 109                   s/'/\\'/g;
 110                   substr($_,$MaxArgLen) = '...'
 111                     if $MaxArgLen and $MaxArgLen < length;
 112                 }
 113                 $_ = "'$_'" unless /^-?[\d.]+$/;
 114                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
 115                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
 116               }
 117               $sub .= '(' . join(', ', @a) . ')';
 118             }
 119             $mess .= "\t$sub " if $error eq "called";
 120             $mess .= "$error at $file line $line\n";
 121         }
 122         $error = "called";
 123     }
 124     # this kludge circumvents die's incorrect handling of NUL
 125     my $msg = \($mess || $error);
 126     $$msg =~ tr/\0//d;
 127     $$msg;
 128 }
 129
 130 sub shortmess { # Short-circuit &longmess if called via multiple packages
 131     my $error = join '', @_;
 132     my ($prevpack) = caller(1);
 133     my $extra = $CarpLevel;
 134     my $i = 2;
 135     my ($pack,$file,$line);
 136     my %isa = ($prevpack,1);
 137
 138     @isa{@{"${prevpack}::ISA"}} = ()
 139         if(defined @{"${prevpack}::ISA"});
 140
 141     while (($pack,$file,$line) = caller($i++)) {
 142         if(defined @{$pack . "::ISA"}) {
 143             my @i = @{$pack . "::ISA"};
 144             my %i;
 145             @i{@i} = ();
 146             @isa{@i,$pack} = ()
 147                 if(exists $i{$prevpack} || exists $isa{$pack});
 148         }
 149
 150         next
 151             if(exists $isa{$pack});
 152
 153         if ($extra-- > 0) {
 154             %isa = ($pack,1);
 155             @isa{@{$pack . "::ISA"}} = ()
 156                 if(defined @{$pack . "::ISA"});
 157         }
 158         else {
 159             # this kludge circumvents die's incorrect handling of NUL
 160             (my $msg = "$error at $file line $line\n") =~ tr/\0//d;
 161             return $msg;
 162         }
 163     }
 164     continue {
 165         $prevpack = $pack;
 166     }
 167
 168     goto &longmess;
 169 }
 170
 171 sub confess { die longmess @_; }
 172 sub croak { die shortmess @_; }
 173 sub carp { warn shortmess @_; }
 174 sub cluck { warn longmess @_; }
 175
 176 1;