You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
222 lines
7.7 KiB
222 lines
7.7 KiB
|
|
##
|
|
## Based on Carp.pm from Perl 5.005_03.
|
|
## Last modified 12-Jun-2001 by Steffen Beyer.
|
|
## Should be reasonably backwards compatible.
|
|
##
|
|
## This module is free software and can
|
|
## be used, modified and redistributed
|
|
## under the same terms as Perl itself.
|
|
##
|
|
|
|
@DB::args = (); # Avoid warning "used only once" in Perl 5.003
|
|
|
|
package Carp::Clan;
|
|
|
|
use strict;
|
|
use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION );
|
|
use overload ();
|
|
|
|
# Original comments by Andy Wardley <abw@kfs.org> 09-Apr-1998.
|
|
|
|
# The $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how
|
|
# the eval text and function arguments should be formatted when printed.
|
|
|
|
$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
|
|
$MaxArgLen = 64; # How much of each argument to print. 0 = all.
|
|
$MaxArgNums = 8; # How many arguments to print. 0 = all.
|
|
|
|
$Verbose = 0; # If true then make _shortmsg call _longmsg instead.
|
|
|
|
$VERSION = '5.8';
|
|
|
|
# _longmsg() crawls all the way up the stack reporting on all the function
|
|
# calls made. The error string, $error, is originally constructed from the
|
|
# arguments passed into _longmsg() via confess(), cluck() or _shortmsg().
|
|
# This gets appended with the stack trace messages which are generated for
|
|
# each function call on the stack.
|
|
|
|
sub _longmsg {
|
|
return (@_) if ( ref $_[0] );
|
|
local $_; # Protect surrounding program - just in case...
|
|
my ( $pack, $file, $line, $sub, $hargs, $eval, $require, @parms, $push );
|
|
my $error = join( '', @_ );
|
|
my $msg = '';
|
|
my $i = 0;
|
|
while (
|
|
do {
|
|
{
|
|
|
|
package DB;
|
|
( $pack, $file, $line, $sub, $hargs, undef, $eval, $require )
|
|
= caller( $i++ )
|
|
}
|
|
}
|
|
)
|
|
{
|
|
next if ( $pack eq 'Carp::Clan' );
|
|
if ( $error eq '' ) {
|
|
if ( defined $eval ) {
|
|
$eval =~ s/([\\\'])/\\$1/g unless ($require); # Escape \ and '
|
|
$eval
|
|
=~ s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
|
|
substr( $eval, $MaxEvalLen ) = '...'
|
|
if ( $MaxEvalLen && length($eval) > $MaxEvalLen );
|
|
if ($require) { $sub = "require $eval"; }
|
|
else { $sub = "eval '$eval'"; }
|
|
}
|
|
elsif ( $sub eq '(eval)' ) { $sub = 'eval {...}'; }
|
|
else {
|
|
@parms = ();
|
|
if ($hargs) {
|
|
$push = 0;
|
|
@parms = @DB::args
|
|
; # We may trash some of the args so we take a copy
|
|
if ( $MaxArgNums and @parms > $MaxArgNums ) {
|
|
$#parms = $MaxArgNums;
|
|
pop(@parms);
|
|
$push = 1;
|
|
}
|
|
for (@parms) {
|
|
if ( defined $_ ) {
|
|
if ( ref $_ ) {
|
|
$_ = overload::StrVal($_);
|
|
}
|
|
else {
|
|
unless ( /^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/
|
|
) # Looks numeric
|
|
{
|
|
s/([\\\'])/\\$1/g; # Escape \ and '
|
|
s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
|
|
substr( $_, $MaxArgLen ) = '...'
|
|
if ( $MaxArgLen
|
|
and length($_) > $MaxArgLen );
|
|
$_ = "'$_'";
|
|
}
|
|
}
|
|
}
|
|
else { $_ = 'undef'; }
|
|
}
|
|
push( @parms, '...' ) if ($push);
|
|
}
|
|
$sub .= '(' . join( ', ', @parms ) . ')';
|
|
}
|
|
if ( $msg eq '' ) { $msg = "$sub called"; }
|
|
else { $msg .= "\t$sub called"; }
|
|
}
|
|
else {
|
|
if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
|
|
else { $msg = "$sub: $error"; }
|
|
}
|
|
$msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
|
|
$error = '';
|
|
}
|
|
$msg ||= $error;
|
|
$msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
|
|
$msg;
|
|
}
|
|
|
|
# _shortmsg() is called by carp() and croak() to skip all the way up to
|
|
# the top-level caller's package and report the error from there. confess()
|
|
# and cluck() generate a full stack trace so they call _longmsg() to
|
|
# generate that. In verbose mode _shortmsg() calls _longmsg() so you
|
|
# always get a stack trace.
|
|
|
|
sub _shortmsg {
|
|
my $pattern = shift;
|
|
my $verbose = shift;
|
|
return (@_) if ( ref $_[0] );
|
|
goto &_longmsg if ( $Verbose or $verbose );
|
|
my ( $pack, $file, $line, $sub );
|
|
my $error = join( '', @_ );
|
|
my $msg = '';
|
|
my $i = 0;
|
|
while ( ( $pack, $file, $line, $sub ) = caller( $i++ ) ) {
|
|
next if ( $pack eq 'Carp::Clan' or $pack =~ /$pattern/ );
|
|
if ( $error eq '' ) { $msg = "$sub() called"; }
|
|
elsif ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
|
|
else { $msg = "$sub: $error"; }
|
|
$msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
|
|
$msg =~ tr/\0//d
|
|
; # Circumvent die's incorrect handling of NUL characters
|
|
return $msg;
|
|
}
|
|
goto &_longmsg;
|
|
}
|
|
|
|
# The following four functions call _longmsg() or _shortmsg() depending on
|
|
# whether they should generate a full stack trace (confess() and cluck())
|
|
# or simply report the caller's package (croak() and carp()), respectively.
|
|
# confess() and croak() die, carp() and cluck() warn.
|
|
|
|
# Following code kept for calls with fully qualified subroutine names:
|
|
# (For backward compatibility with the original Carp.pm)
|
|
|
|
sub croak {
|
|
my $callpkg = caller(0);
|
|
my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
|
|
die _shortmsg( $pattern, 0, @_ );
|
|
}
|
|
sub confess { die _longmsg(@_); }
|
|
|
|
sub carp {
|
|
my $callpkg = caller(0);
|
|
my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
|
|
warn _shortmsg( $pattern, 0, @_ );
|
|
}
|
|
sub cluck { warn _longmsg(@_); }
|
|
|
|
# The following method imports a different closure for every caller.
|
|
# I.e., different modules can use this module at the same time
|
|
# and in parallel and still use different patterns.
|
|
|
|
sub import {
|
|
my $pkg = shift;
|
|
my $callpkg = caller(0);
|
|
my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
|
|
my $verbose = 0;
|
|
my $item;
|
|
my $file;
|
|
|
|
for $item (@_) {
|
|
if ( $item =~ /^\d/ ) {
|
|
if ( $VERSION < $item ) {
|
|
$file = "$pkg.pm";
|
|
$file =~ s!::!/!g;
|
|
$file = $INC{$file};
|
|
die _shortmsg( '^:::', 0,
|
|
"$pkg $item required--this is only version $VERSION ($file)"
|
|
);
|
|
}
|
|
}
|
|
elsif ( $item =~ /^verbose$/i ) { $verbose = 1; }
|
|
else { $pattern = $item; }
|
|
}
|
|
|
|
# Speed up pattern matching in Perl versions >= 5.005:
|
|
# (Uses "eval ''" because qr// is a syntax error in previous Perl versions)
|
|
if ( $] >= 5.005 ) {
|
|
eval '$pattern = qr/$pattern/;';
|
|
}
|
|
else {
|
|
eval { $pkg =~ /$pattern/; };
|
|
}
|
|
if ($@) {
|
|
$@ =~ s/\s+$//;
|
|
$@ =~ s/\s+at\s.+$//;
|
|
die _shortmsg( '^:::', 0, $@ );
|
|
}
|
|
{
|
|
local ($^W) = 0;
|
|
no strict "refs";
|
|
*{"${callpkg}::croak"}
|
|
= sub { die _shortmsg( $pattern, $verbose, @_ ); };
|
|
*{"${callpkg}::confess"} = sub { die _longmsg(@_); };
|
|
*{"${callpkg}::carp"}
|
|
= sub { warn _shortmsg( $pattern, $verbose, @_ ); };
|
|
*{"${callpkg}::cluck"} = sub { warn _longmsg(@_); };
|
|
}
|
|
}
|
|
|
|
1;
|
|
|