@DB::args = ();
package Carp::Clan;
use strict;
use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION );
$MaxEvalLen = 0; $MaxArgLen = 64; $MaxArgNums = 8;
$Verbose = 0;
$VERSION = '5.3';
sub _longmsg
{
return(@_) if (ref $_[0]);
local $^W = 0; local $_; 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); $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; if ($MaxArgNums and @parms > $MaxArgNums)
{
$ pop(@parms);
$push = 1;
}
for (@parms)
{
if (defined $_)
{
if (ref $_)
{
$_ = "$_"; }
else
{
unless (/^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/) {
s/([\\\'])/\\$1/g; 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;
}
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;
}
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(@_); }
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; }
}
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;