# these are called, they require Carp::Heavy which installs the real
# routines.
-# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
-# _almost_ complete understanding of the package. Corrections and
-# comments are welcome.
-
# The members of %Internal are packages that are internal to perl.
# Carp will not report errors from within these packages if it
# can. The members of %CarpInternal are internal to Perl's warning
# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
# text and function arguments should be formatted when printed.
-# Comments added by Jos I. Boumans <kane@dwim.org> 11-Aug-2004
-# I can not get %CarpInternal or %Internal to work as advertised,
-# therefore leaving it out of the below documentation.
-# $CarpLevel may be decprecated according to the last comment, but
-# after 6 years, it's still around and in heavy use ;)
-
# disable these by default, so they can live w/o require Carp
$CarpInternal{Carp}++;
$CarpInternal{warnings}++;
sub longmess_real {
# Icky backwards compatibility wrapper. :-(
+ #
+ # The story is that the original implementation hard-coded the
+ # number of call levels to go back, so calls to longmess were off
+ # by one. Other code began calling longmess and expecting this
+ # behaviour, so the replacement has to emulate that behaviour.
my $call_pack = caller();
if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
return longmess_heavy(@_);
sub shortmess_real {
# Icky backwards compatibility wrapper. :-(
- my $call_pack = caller();
local @CARP_NOT = caller();
shortmess_heavy(@_);
};
# aliasing the whole glob rather than just the CV slot avoids 'redefined'
# warnings, even in the presence of perl -W (as used by lib/warnings.t !)
+# However it has the potential to create infinite loops, if somehow Carp
+# is forcibly reloaded, but $INC{"Carp/Heavy.pm"} remains true.
+# Hence the extra hack of deleting the previous typeglob first.
+delete $Carp::{shortmess_jmp};
+delete $Carp::{longmess_jmp};
*longmess_jmp = *longmess_real;
*shortmess_jmp = *shortmess_real;
# Transform an argument to a function into a string.
sub format_arg {
my $arg = shift;
- if (not defined($arg)) {
- $arg = 'undef';
- }
- elsif (ref($arg)) {
+ if (ref($arg)) {
$arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
+ }elsif (not defined($arg)) {
+ $arg = 'undef';
}
$arg =~ s/'/\\'/g;
$arg = str_len_trim($arg, $MaxArgLen);
$arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
# The following handling of "control chars" is direct from
- # the original code - I think it is broken on Unicode though.
+ # the original code - it is broken on Unicode though.
# Suggestions?
- $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
+ utf8::is_utf8($arg)
+ or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
return $arg;
}
sub short_error_loc {
- my $cache;
+ # You have to create your (hash)ref out here, rather than defaulting it
+ # inside trusts *on a lexical*, as you want it to persist across calls.
+ # (You can default it on $_[2], but that gets messy)
+ my $cache = {};
my $i = 1;
my $lvl = $CarpLevel;
{
return 0 unless defined($caller); # What happened?
redo if $Internal{$caller};
+ redo if $CarpInternal{$caller};
redo if $CarpInternal{$called};
redo if trusts($called, $caller, $cache);
redo if trusts($caller, $called, $cache);
sub trusts {
my $child = shift;
my $parent = shift;
- my $cache = shift || {};
+ my $cache = shift;
my ($known, $partial) = get_status($cache, $child);
# Figure out consequences until we have an answer
while (@$partial and not exists $known->{$parent}) {