local-lib5/lib/perl5/Carp/Clan.pm

   1
   2 ##
   3 ## Based on Carp.pm from Perl 5.005_03.
   4 ## Last modified 24-Oct-2009 by Steffen Beyer.
   5 ## Should be reasonably backwards compatible.
   6 ##
   7 ## This module is free software and can
   8 ## be used, modified and redistributed
   9 ## under the same terms as Perl itself.
  10 ##
  11
  12 @DB::args = ();    # Avoid warning "used only once" in Perl 5.003
  13
  14 package Carp::Clan;
  15
  16 use strict;
  17 use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION );
  18 use overload ();
  19
  20 # Original comments by Andy Wardley <abw@kfs.org> 09-Apr-1998.
  21
  22 # The $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how
  23 # the eval text and function arguments should be formatted when printed.
  24
  25 $MaxEvalLen = 0;     # How much eval '...text...' to show. 0 = all.
  26 $MaxArgLen  = 64;    # How much of each argument to print. 0 = all.
  27 $MaxArgNums = 8;     # How many arguments to print.        0 = all.
  28
  29 $Verbose = 0;        # If true then make _shortmsg call _longmsg instead.
  30
  31 $VERSION = '6.04';
  32
  33 # _longmsg() crawls all the way up the stack reporting on all the function
  34 # calls made. The error string, $error, is originally constructed from the
  35 # arguments passed into _longmsg() via confess(), cluck() or _shortmsg().
  36 # This gets appended with the stack trace messages which are generated for
  37 # each function call on the stack.
  38
  39 sub _longmsg {
  40     return (@_) if ( ref $_[0] );
  41     local $_;        # Protect surrounding program - just in case...
  42     my ( $pack, $file, $line, $sub, $hargs, $eval, $require, @parms, $push );
  43     my $error = join( '', @_ );
  44     my $msg   = '';
  45     my $i     = 0;
  46     while (
  47         do {
  48             {
  49
  50                 package DB;
  51                 ( $pack, $file, $line, $sub, $hargs, undef, $eval, $require )
  52                     = caller( $i++ )
  53             }
  54         }
  55         )
  56     {
  57         next if ( $pack eq 'Carp::Clan' );
  58         if ( $error eq '' ) {
  59             if ( defined $eval ) {
  60                 $eval =~ s/([\\\'])/\\$1/g unless ($require); # Escape \ and '
  61                 $eval
  62                     =~ s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
  63                 substr( $eval, $MaxEvalLen ) = '...'
  64                     if ( $MaxEvalLen && length($eval) > $MaxEvalLen );
  65                 if   ($require) { $sub = "require $eval"; }
  66                 else            { $sub = "eval '$eval'"; }
  67             }
  68             elsif ( $sub eq '(eval)' ) { $sub = 'eval {...}'; }
  69             else {
  70                 @parms = ();
  71                 if ($hargs) {
  72                     $push  = 0;
  73                     @parms = @DB::args
  74                         ;    # We may trash some of the args so we take a copy
  75                     if ( $MaxArgNums and @parms > $MaxArgNums ) {
  76                         $#parms = $MaxArgNums;
  77                         pop(@parms);
  78                         $push = 1;
  79                     }
  80                     for (@parms) {
  81                         if ( defined $_ ) {
  82                             if ( ref $_ ) {
  83                                 $_ = overload::StrVal($_);
  84                             }
  85                             else {
  86                                 unless ( /^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/
  87                                     )    # Looks numeric
  88                                 {
  89                                     s/([\\\'])/\\$1/g;    # Escape \ and '
  90                                     s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
  91                                     substr( $_, $MaxArgLen ) = '...'
  92                                         if ( $MaxArgLen
  93                                         and length($_) > $MaxArgLen );
  94                                     $_ = "'$_'";
  95                                 }
  96                             }
  97                         }
  98                         else { $_ = 'undef'; }
  99                     }
 100                     push( @parms, '...' ) if ($push);
 101                 }
 102                 $sub .= '(' . join( ', ', @parms ) . ')';
 103             }
 104             if ( $msg eq '' ) { $msg = "$sub called"; }
 105             else              { $msg .= "\t$sub called"; }
 106         }
 107         else {
 108             $msg = quotemeta($sub);
 109             if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
 110             else {
 111                 if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
 112                 else                { $msg = "$sub: $error"; }
 113             }
 114         }
 115         $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
 116         $error = '';
 117     }
 118     $msg ||= $error;
 119     $msg =~ tr/\0//d;  # Circumvent die's incorrect handling of NUL characters
 120     $msg;
 121 }
 122
 123 # _shortmsg() is called by carp() and croak() to skip all the way up to
 124 # the top-level caller's package and report the error from there. confess()
 125 # and cluck() generate a full stack trace so they call _longmsg() to
 126 # generate that. In verbose mode _shortmsg() calls _longmsg() so you
 127 # always get a stack trace.
 128
 129 sub _shortmsg {
 130     my $pattern = shift;
 131     my $verbose = shift;
 132     return (@_) if ( ref $_[0] );
 133     goto &_longmsg if ( $Verbose or $verbose );
 134     my ( $pack, $file, $line, $sub );
 135     my $error = join( '', @_ );
 136     my $msg   = '';
 137     my $i     = 0;
 138     while ( ( $pack, $file, $line, $sub ) = caller( $i++ ) ) {
 139         next if ( $pack eq 'Carp::Clan' or $pack =~ /$pattern/ );
 140         if ( $error eq '' ) { $msg = "$sub() called"; }
 141         else {
 142             $msg = quotemeta($sub);
 143             if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
 144             else {
 145                 if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
 146                 else                { $msg = "$sub: $error"; }
 147             }
 148         }
 149         $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
 150         $msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
 151         return $msg;
 152     }
 153     goto &_longmsg;
 154 }
 155
 156 # In the two identical regular expressions (immediately after the two occurrences of
 157 # "quotemeta") above, the "\b ... \b" helps to avoid confusion between function names
 158 # which are prefixes of each other, e.g. "My::Class::print" and "My::Class::println".
 159
 160 # The following four functions call _longmsg() or _shortmsg() depending on
 161 # whether they should generate a full stack trace (confess() and cluck())
 162 # or simply report the caller's package (croak() and carp()), respectively.
 163 # confess() and croak() die, carp() and cluck() warn.
 164
 165 # Following code kept for calls with fully qualified subroutine names:
 166 # (For backward compatibility with the original Carp.pm)
 167
 168 sub croak {
 169     my $callpkg = caller(0);
 170     my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
 171     die _shortmsg( $pattern, 0, @_ );
 172 }
 173 sub confess { die _longmsg(@_); }
 174
 175 sub carp {
 176     my $callpkg = caller(0);
 177     my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
 178     warn _shortmsg( $pattern, 0, @_ );
 179 }
 180 sub cluck { warn _longmsg(@_); }
 181
 182 # The following method imports a different closure for every caller.
 183 # I.e., different modules can use this module at the same time
 184 # and in parallel and still use different patterns.
 185
 186 sub import {
 187     my $pkg     = shift;
 188     my $callpkg = caller(0);
 189     my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
 190     my $verbose = 0;
 191     my $item;
 192     my $file;
 193
 194     for $item (@_) {
 195         if ( $item =~ /^\d/ ) {
 196             if ( $VERSION < $item ) {
 197                 $file = "$pkg.pm";
 198                 $file =~ s!::!/!g;
 199                 $file = $INC{$file};
 200                 die _shortmsg( '^:::', 0,
 201                     "$pkg $item required--this is only version $VERSION ($file)"
 202                 );
 203             }
 204         }
 205         elsif ( $item =~ /^verbose$/i ) { $verbose = 1; }
 206         else                            { $pattern = $item; }
 207     }
 208
 209    # Speed up pattern matching in Perl versions >= 5.005:
 210    # (Uses "eval ''" because qr// is a syntax error in previous Perl versions)
 211     if ( $] >= 5.005 ) {
 212         eval '$pattern = qr/$pattern/;';
 213     }
 214     else {
 215         eval { $pkg =~ /$pattern/; };
 216     }
 217     if ($@) {
 218         $@ =~ s/\s+$//;
 219         $@ =~ s/\s+at\s.+$//;
 220         die _shortmsg( '^:::', 0, $@ );
 221     }
 222     {
 223         local ($^W) = 0;
 224         no strict "refs";
 225         *{"${callpkg}::croak"}   = sub { die  _shortmsg( $pattern, $verbose, @_ ); };
 226         *{"${callpkg}::confess"} = sub { die  _longmsg (                     @_ ); };
 227         *{"${callpkg}::carp"}    = sub { warn _shortmsg( $pattern, $verbose, @_ ); };
 228         *{"${callpkg}::cluck"}   = sub { warn _longmsg (                     @_ ); };
 229     }
 230 }
 231
 232 1;
 233