1N/A# Carp::Heavy uses some variables in common with Carp.
1N/Apackage Carp;
1N/A
1N/A=head1 NAME
1N/A
1N/ACarp::Heavy - heavy machinery, no user serviceable parts inside
1N/A
1N/A=cut
1N/A
1N/A# use strict; # not yet
1N/A
1N/A# On one line so MakeMaker will see it.
1N/Ause Carp; our $VERSION = $Carp::VERSION;
1N/A
1N/Aour ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
1N/A
1N/Asub caller_info {
1N/A my $i = shift(@_) + 1;
1N/A package DB;
1N/A my %call_info;
1N/A @call_info{
1N/A qw(pack file line sub has_args wantarray evaltext is_require)
1N/A } = caller($i);
1N/A
1N/A unless (defined $call_info{pack}) {
1N/A return ();
1N/A }
1N/A
1N/A my $sub_name = Carp::get_subname(\%call_info);
1N/A if ($call_info{has_args}) {
1N/A my @args = map {Carp::format_arg($_)} @DB::args;
1N/A if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
1N/A $#args = $MaxArgNums;
1N/A push @args, '...';
1N/A }
1N/A # Push the args onto the subroutine
1N/A $sub_name .= '(' . join (', ', @args) . ')';
1N/A }
1N/A $call_info{sub_name} = $sub_name;
1N/A return wantarray() ? %call_info : \%call_info;
1N/A}
1N/A
1N/A# Transform an argument to a function into a string.
1N/Asub format_arg {
1N/A my $arg = shift;
1N/A if (not defined($arg)) {
1N/A $arg = 'undef';
1N/A }
1N/A elsif (ref($arg)) {
1N/A $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
1N/A }
1N/A $arg =~ s/'/\\'/g;
1N/A $arg = str_len_trim($arg, $MaxArgLen);
1N/A
1N/A # Quote it?
1N/A $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
1N/A
1N/A # The following handling of "control chars" is direct from
1N/A # the original code - I think it is broken on Unicode though.
1N/A # Suggestions?
1N/A $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
1N/A return $arg;
1N/A}
1N/A
1N/A# Takes an inheritance cache and a package and returns
1N/A# an anon hash of known inheritances and anon array of
1N/A# inheritances which consequences have not been figured
1N/A# for.
1N/Asub get_status {
1N/A my $cache = shift;
1N/A my $pkg = shift;
1N/A $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
1N/A return @{$cache->{$pkg}};
1N/A}
1N/A
1N/A# Takes the info from caller() and figures out the name of
1N/A# the sub/require/eval
1N/Asub get_subname {
1N/A my $info = shift;
1N/A if (defined($info->{evaltext})) {
1N/A my $eval = $info->{evaltext};
1N/A if ($info->{is_require}) {
1N/A return "require $eval";
1N/A }
1N/A else {
1N/A $eval =~ s/([\\\'])/\\$1/g;
1N/A return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
1N/A }
1N/A }
1N/A
1N/A return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
1N/A}
1N/A
1N/A# Figures out what call (from the point of view of the caller)
1N/A# the long error backtrace should start at.
1N/Asub long_error_loc {
1N/A my $i;
1N/A my $lvl = $CarpLevel;
1N/A {
1N/A my $pkg = caller(++$i);
1N/A unless(defined($pkg)) {
1N/A # This *shouldn't* happen.
1N/A if (%Internal) {
1N/A local %Internal;
1N/A $i = long_error_loc();
1N/A last;
1N/A }
1N/A else {
1N/A # OK, now I am irritated.
1N/A return 2;
1N/A }
1N/A }
1N/A redo if $CarpInternal{$pkg};
1N/A redo unless 0 > --$lvl;
1N/A redo if $Internal{$pkg};
1N/A }
1N/A return $i - 1;
1N/A}
1N/A
1N/A
1N/Asub longmess_heavy {
1N/A return @_ if ref($_[0]); # don't break references as exceptions
1N/A my $i = long_error_loc();
1N/A return ret_backtrace($i, @_);
1N/A}
1N/A
1N/A# Returns a full stack backtrace starting from where it is
1N/A# told.
1N/Asub ret_backtrace {
1N/A my ($i, @error) = @_;
1N/A my $mess;
1N/A my $err = join '', @error;
1N/A $i++;
1N/A
1N/A my $tid_msg = '';
1N/A if (defined &Thread::tid) {
1N/A my $tid = Thread->self->tid;
1N/A $tid_msg = " thread $tid" if $tid;
1N/A }
1N/A
1N/A { if ($err =~ /\n$/) { # extra block to localise $1 etc
1N/A $mess = $err;
1N/A }
1N/A else {
1N/A my %i = caller_info($i);
1N/A $mess = "$err at $i{file} line $i{line}$tid_msg\n";
1N/A }}
1N/A
1N/A while (my %i = caller_info(++$i)) {
1N/A $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
1N/A }
1N/A
1N/A return $mess;
1N/A}
1N/A
1N/Asub ret_summary {
1N/A my ($i, @error) = @_;
1N/A my $mess;
1N/A my $err = join '', @error;
1N/A $i++;
1N/A
1N/A my $tid_msg = '';
1N/A if (defined &Thread::tid) {
1N/A my $tid = Thread->self->tid;
1N/A $tid_msg = " thread $tid" if $tid;
1N/A }
1N/A
1N/A my %i = caller_info($i);
1N/A return "$err at $i{file} line $i{line}$tid_msg\n";
1N/A}
1N/A
1N/A
1N/Asub short_error_loc {
1N/A my $cache;
1N/A my $i = 1;
1N/A my $lvl = $CarpLevel;
1N/A {
1N/A my $called = caller($i++);
1N/A my $caller = caller($i);
1N/A return 0 unless defined($caller); # What happened?
1N/A redo if $Internal{$caller};
1N/A redo if $CarpInternal{$called};
1N/A redo if trusts($called, $caller, $cache);
1N/A redo if trusts($caller, $called, $cache);
1N/A redo unless 0 > --$lvl;
1N/A }
1N/A return $i - 1;
1N/A}
1N/A
1N/Asub shortmess_heavy {
1N/A return longmess_heavy(@_) if $Verbose;
1N/A return @_ if ref($_[0]); # don't break references as exceptions
1N/A my $i = short_error_loc();
1N/A if ($i) {
1N/A ret_summary($i, @_);
1N/A }
1N/A else {
1N/A longmess_heavy(@_);
1N/A }
1N/A}
1N/A
1N/A# If a string is too long, trims it with ...
1N/Asub str_len_trim {
1N/A my $str = shift;
1N/A my $max = shift || 0;
1N/A if (2 < $max and $max < length($str)) {
1N/A substr($str, $max - 3) = '...';
1N/A }
1N/A return $str;
1N/A}
1N/A
1N/A# Takes two packages and an optional cache. Says whether the
1N/A# first inherits from the second.
1N/A#
1N/A# Recursive versions of this have to work to avoid certain
1N/A# possible endless loops, and when following long chains of
1N/A# inheritance are less efficient.
1N/Asub trusts {
1N/A my $child = shift;
1N/A my $parent = shift;
1N/A my $cache = shift || {};
1N/A my ($known, $partial) = get_status($cache, $child);
1N/A # Figure out consequences until we have an answer
1N/A while (@$partial and not exists $known->{$parent}) {
1N/A my $anc = shift @$partial;
1N/A next if exists $known->{$anc};
1N/A $known->{$anc}++;
1N/A my ($anc_knows, $anc_partial) = get_status($cache, $anc);
1N/A my @found = keys %$anc_knows;
1N/A @$known{@found} = ();
1N/A push @$partial, @$anc_partial;
1N/A }
1N/A return exists $known->{$parent};
1N/A}
1N/A
1N/A# Takes a package and gives a list of those trusted directly
1N/Asub trusts_directly {
1N/A my $class = shift;
1N/A no strict 'refs';
1N/A no warnings 'once';
1N/A return @{"$class\::CARP_NOT"}
1N/A ? @{"$class\::CARP_NOT"}
1N/A : @{"$class\::ISA"};
1N/A}
1N/A
1N/A1;
1N/A