lib/Carp/Heavy.pm

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