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