lib/Carp/Heavy.pm

   1 # Carp::Heavy uses some variables in common with Carp.
   2 package Carp;
   3
   4 =head1 NAME
   5
   6 Carp heavy machinery - no user serviceable parts inside
   7
   8 =cut
   9
  10 # use strict; # not yet
  11
  12 # On one line so MakeMaker will see it.
  13 use Carp;  our $VERSION = $Carp::VERSION;
  14
  15 our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $Verbose);
  16
  17 sub caller_info {
  18   my $i = shift(@_) + 1;
  19   package DB;
  20   my %call_info;
  21   @call_info{
  22     qw(pack file line sub has_args wantarray evaltext is_require)
  23   } = caller($i);
  24
  25   unless (defined $call_info{pack}) {
  26     return ();
  27   }
  28
  29   my $sub_name = Carp::get_subname(\%call_info);
  30   if ($call_info{has_args}) {
  31     # Reuse the @args array to avoid warnings. :-)
  32     local @args = map {Carp::format_arg($_)} @args;
  33     if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
  34       $#args = $MaxArgNums;
  35       push @args, '...';
  36     }
  37     # Push the args onto the subroutine
  38     $sub_name .= '(' . join (',', @args) . ')';
  39   }
  40   $call_info{sub_name} = $sub_name;
  41   return wantarray() ? %call_info : \%call_info;
  42 }
  43
  44 # Transform an argument to a function into a string.
  45 sub format_arg {
  46   my $arg = shift;
  47   if (not defined($arg)) {
  48     $arg = 'undef';
  49   }
  50   elsif (ref($arg)) {
  51       $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
  52   }
  53   $arg =~ s/'/\\'/g;
  54   $arg = str_len_trim($arg, $MaxLenArg);
  55
  56   # Quote it?
  57   $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
  58
  59   # The following handling of "control chars" is direct from
  60   # the original code - I think it is broken on Unicode though.
  61   # Suggestions?
  62   $arg =~ s/([[:cntrl:]]|[[^:ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
  63   return $arg;
  64 }
  65
  66 # Takes an inheritance cache and a package and returns
  67 # an anon hash of known inheritances and anon array of
  68 # inheritances which consequences have not been figured
  69 # for.
  70 sub get_status {
  71     my $cache = shift;
  72     my $pkg = shift;
  73     $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
  74     return @{$cache->{$pkg}};
  75 }
  76
  77 # Takes the info from caller() and figures out the name of
  78 # the sub/require/eval
  79 sub get_subname {
  80   my $info = shift;
  81   if (defined($info->{eval})) {
  82     my $eval = $info->{eval};
  83     if ($info->{is_require}) {
  84       return "require $eval";
  85     }
  86     else {
  87       $eval =~ s/([\\\'])/\\$1/g;
  88       return str_len_trim($eval, $MaxEvalLen);
  89     }
  90   }
  91
  92   return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
  93 }
  94
  95 # Figures out what call (from the point of view of the caller)
  96 # the long error backtrace should start at.
  97 sub long_error_loc {
  98   my $i;
  99   my $lvl = $CarpLevel;
 100   {
 101     my $pkg = caller(++$i);
 102     unless(defined($pkg)) {
 103       # This *shouldn't* happen.
 104       if (%Internal) {
 105         local %Internal;
 106         $i = long_error_loc();
 107         last;
 108       }
 109       else {
 110         # OK, now I am irritated.
 111         return 2;
 112       }
 113     }
 114     redo if $CarpInternal{$pkg};
 115     redo unless 0 > --$lvl;
 116     redo if $Internal{$pkg};
 117   }
 118   return $i - 1;
 119 }
 120
 121
 122 sub longmess_heavy {
 123   return @_ if ref($_[0]); # WHAT IS THIS FOR???
 124   my $i = long_error_loc();
 125   return ret_backtrace($i, @_);
 126 }
 127
 128 # Returns a full stack backtrace starting from where it is
 129 # told.
 130 sub ret_backtrace {
 131   my ($i, @error) = @_;
 132   my $mess;
 133   my $err = join '', @error;
 134   $i++;
 135
 136   my $tid_msg = '';
 137   if (defined &Thread::tid) {
 138     my $tid = Thread->self->tid;
 139     $tid_msg = " thread $tid" if $tid;
 140   }
 141
 142   if ($err =~ /\n$/) {
 143     $mess = $err;
 144   }
 145   else {
 146     my %i = caller_info($i);
 147     $mess = "$err at $i{file} line $i{line}$tid_msg\n";
 148   }
 149
 150   while (my %i = caller_info(++$i)) {
 151       $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
 152   }
 153
 154   return $mess || $err;
 155 }
 156
 157 sub ret_summary {
 158   my ($i, @error) = @_;
 159   my $mess;
 160   my $err = join '', @error;
 161   $i++;
 162
 163   my $tid_msg = '';
 164   if (defined &Thread::tid) {
 165     my $tid = Thread->self->tid;
 166     $tid_msg = " thread $tid" if $tid;
 167   }
 168
 169   my %i = caller_info($i);
 170   return "$err at $i{file} line $i{line}$tid_msg\n";
 171 }
 172
 173
 174 sub short_error_loc {
 175   my $cache;
 176   my $i = 1;
 177   my $lvl = $CarpLevel;
 178   {
 179     my $called = caller($i++);
 180     my $caller = caller($i);
 181     return 0 unless defined($caller); # What happened?
 182     redo if $Internal{$caller};
 183     redo if $CarpInternal{$called};
 184     redo if trusts($called, $caller, $cache);
 185     redo if trusts($caller, $called, $cache);
 186     redo unless 0 > --$lvl;
 187   }
 188   return $i - 1;
 189 }
 190
 191 sub shortmess_heavy {
 192   return longmess_heavy(@_) if $Verbose;
 193   return @_ if ref($_[0]); # WHAT IS THIS FOR???
 194   my $i = short_error_loc();
 195   if ($i) {
 196     ret_summary($i, @_);
 197   }
 198   else {
 199     longmess_heavy(@_);
 200   }
 201 }
 202
 203 # If a string is too long, trims it with ...
 204 sub str_len_trim {
 205   my $str = shift;
 206   my $max = shift || 0;
 207   if (2 < $max and $max < length($str)) {
 208     substr($str, $max - 3) = '...';
 209   }
 210   return $str;
 211 }
 212
 213 # Takes two packages and an optional cache.  Says whether the
 214 # first inherits from the second.
 215 #
 216 # Recursive versions of this have to work to avoid certain
 217 # possible endless loops, and when following long chains of
 218 # inheritance are less efficient.
 219 sub trusts {
 220     my $child = shift;
 221     my $parent = shift;
 222     my $cache = shift || {};
 223     my ($known, $partial) = get_status($cache, $child);
 224     # Figure out consequences until we have an answer
 225     while (@$partial and not exists $known->{$parent}) {
 226         my $anc = shift @$partial;
 227         next if exists $known->{$anc};
 228         $known->{$anc}++;
 229         my ($anc_knows, $anc_partial) = get_status($cache, $anc);
 230         my @found = keys %$anc_knows;
 231         @$known{@found} = ();
 232         push @$partial, @$anc_partial;
 233     }
 234     return exists $known->{$parent};
 235 }
 236
 237 # Takes a package and gives a list of those trusted directly
 238 sub trusts_directly {
 239     my $class = shift;
 240     return @{"$class\::ISA"};
 241 }
 242
 243 1;
 244