lib/Carp/Heavy.pm

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