=head1 NAME
-Carp heavy machinery - no user serviceable parts inside
+Carp::Heavy - heavy machinery, no user serviceable parts inside
=cut
-# use strict; # not yet
-
# On one line so MakeMaker will see it.
use Carp; our $VERSION = $Carp::VERSION;
+# use strict; # not yet
+
+# 'use Carp' just installs some very lightweight stubs; the first time
+# these are called, they require Carp::Heavy which installs the real
+# routines.
+
+# 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
+# system. Carp will not report errors from within these packages
+# either, and will not report calls *to* these packages for carp and
+# croak. They replace $CarpLevel, which is deprecated. The
+# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
+# text and function arguments should be formatted when printed.
+
+# disable these by default, so they can live w/o require Carp
+$CarpInternal{Carp}++;
+$CarpInternal{warnings}++;
+$Internal{Exporter}++;
+$Internal{'Exporter::Heavy'}++;
+
+
+our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
+
+# XXX longmess_real and shortmess_real should really be merged into
+# XXX {long|sort}mess_heavy at some point
+
+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(@_);
+ }
+ else {
+ local $CarpLevel = $CarpLevel + 1;
+ return longmess_heavy(@_);
+ }
+};
+
+sub shortmess_real {
+ # Icky backwards compatibility wrapper. :-(
+ my $call_pack = caller();
+ local @CARP_NOT = caller();
+ shortmess_heavy(@_);
+};
+
+# replace the two hooks added by Carp
+
+# 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 !)
+
+*longmess_jmp = *longmess_real;
+*shortmess_jmp = *shortmess_real;
-our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $Verbose);
sub caller_info {
my $i = shift(@_) + 1;
my $sub_name = Carp::get_subname(\%call_info);
if ($call_info{has_args}) {
- # Reuse the @args array to avoid warnings. :-)
- local @args = map {Carp::format_arg($_)} @args;
+ my @args = map {Carp::format_arg($_)} @DB::args;
if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
$#args = $MaxArgNums;
push @args, '...';
}
# Push the args onto the subroutine
- $sub_name .= '(' . join (',', @args) . ')';
+ $sub_name .= '(' . join (', ', @args) . ')';
}
$call_info{sub_name} = $sub_name;
return wantarray() ? %call_info : \%call_info;
# 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, $MaxLenArg);
+ $arg = str_len_trim($arg, $MaxArgLen);
# Quote it?
$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;
}
# the sub/require/eval
sub get_subname {
my $info = shift;
- if (defined($info->{eval})) {
- my $eval = $info->{eval};
+ if (defined($info->{evaltext})) {
+ my $eval = $info->{evaltext};
if ($info->{is_require}) {
return "require $eval";
}
else {
$eval =~ s/([\\\'])/\\$1/g;
- return str_len_trim($eval, $MaxEvalLen);
+ return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
}
}
sub longmess_heavy {
- return @_ if ref($_[0]); # WHAT IS THIS FOR???
+ return @_ if ref($_[0]); # don't break references as exceptions
my $i = long_error_loc();
return ret_backtrace($i, @_);
}
$tid_msg = " thread $tid" if $tid;
}
- if ($err =~ /\n$/) {
- $mess = $err;
- }
- else {
- my %i = caller_info($i);
- $mess = "$err at $i{file} line $i{line}$tid_msg\n";
- }
+ my %i = caller_info($i);
+ $mess = "$err at $i{file} line $i{line}$tid_msg\n";
while (my %i = caller_info(++$i)) {
$mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
}
- return $mess || $err;
+ return $mess;
}
sub ret_summary {
my ($i, @error) = @_;
- my $mess;
my $err = join '', @error;
$i++;
{
my $called = caller($i++);
my $caller = caller($i);
+
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);
return $i - 1;
}
+
sub shortmess_heavy {
return longmess_heavy(@_) if $Verbose;
- return @_ if ref($_[0]); # WHAT IS THIS FOR???
+ return @_ if ref($_[0]); # don't break references as exceptions
my $i = short_error_loc();
if ($i) {
ret_summary($i, @_);
# Takes a package and gives a list of those trusted directly
sub trusts_directly {
my $class = shift;
- return @{"$class\::ISA"};
+ no strict 'refs';
+ no warnings 'once';
+ return @{"$class\::CARP_NOT"}
+ ? @{"$class\::CARP_NOT"}
+ : @{"$class\::ISA"};
}
1;
projects / p5sagit/p5-mst-13.2.git / blobdiff