/usr/share/perl5/Carp/Clan.pm is in libcarp-clan-perl 6.06-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 | ##
## Based on Carp.pm from Perl 5.005_03.
## Last modified 22-May-2016 by Kent Fredric.
## 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 = '6.06';
# _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 {
$msg = quotemeta($sub);
if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
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"; }
else {
$msg = quotemeta($sub);
if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
else {
if ( $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;
}
# In the two identical regular expressions (immediately after the two occurrences of
# "quotemeta") above, the "\b ... \b" helps to avoid confusion between function names
# which are prefixes of each other, e.g. "My::Class::print" and "My::Class::println".
# 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;
|