home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _dd646a5c6fc91e99dc1497ac689e217e < prev    next >
Text File  |  2000-03-15  |  9KB  |  254 lines
  1. package Carp;
  2.  
  3. =head1 NAME
  4.  
  5. Carp::Heavy - Carp guts
  6.  
  7. =head1 SYNOPIS
  8.  
  9. (internal use only)
  10.  
  11. =head1 DESCRIPTION
  12.  
  13. No user-serviceable parts inside.
  14.  
  15. =cut
  16.  
  17. # This package is heavily used. Be small. Be fast. Be good.
  18.  
  19. # Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
  20. # _almost_ complete understanding of the package.  Corrections and
  21. # comments are welcome.
  22.  
  23. # longmess() crawls all the way up the stack reporting on all the function
  24. # calls made.  The error string, $error, is originally constructed from the
  25. # arguments passed into longmess() via confess(), cluck() or shortmess().
  26. # This gets appended with the stack trace messages which are generated for
  27. # each function call on the stack.
  28.  
  29. sub longmess_heavy {
  30.     return @_ if ref $_[0];
  31.     my $error = join '', @_;
  32.     my $mess = "";
  33.     my $i = 1 + $CarpLevel;
  34.     my ($pack,$file,$line,$sub,$hargs,$eval,$require);
  35.     my (@a);
  36.     #
  37.     # crawl up the stack....
  38.     #
  39.     while (do { { package DB; @a = caller($i++) } } ) {
  40.     # get copies of the variables returned from caller()
  41.     ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
  42.     #
  43.     # if the $error error string is newline terminated then it
  44.     # is copied into $mess.  Otherwise, $mess gets set (at the end of
  45.     # the 'else {' section below) to one of two things.  The first time
  46.     # through, it is set to the "$error at $file line $line" message.
  47.     # $error is then set to 'called' which triggers subsequent loop
  48.     # iterations to append $sub to $mess before appending the "$error
  49.     # at $file line $line" which now actually reads "called at $file line
  50.     # $line".  Thus, the stack trace message is constructed:
  51.     #
  52.     #        first time: $mess  = $error at $file line $line
  53.     #  subsequent times: $mess .= $sub $error at $file line $line
  54.     #                                  ^^^^^^
  55.     #                                 "called"
  56.     if ($error =~ m/\n$/) {
  57.         $mess .= $error;
  58.     } else {
  59.         # Build a string, $sub, which names the sub-routine called.
  60.         # This may also be "require ...", "eval '...' or "eval {...}"
  61.         if (defined $eval) {
  62.         if ($require) {
  63.             $sub = "require $eval";
  64.         } else {
  65.             $eval =~ s/([\\\'])/\\$1/g;
  66.             if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
  67.             substr($eval,$MaxEvalLen) = '...';
  68.             }
  69.             $sub = "eval '$eval'";
  70.         }
  71.         } elsif ($sub eq '(eval)') {
  72.         $sub = 'eval {...}';
  73.         }
  74.         # if there are any arguments in the sub-routine call, format
  75.         # them according to the format variables defined earlier in
  76.         # this file and join them onto the $sub sub-routine string
  77.         if ($hargs) {
  78.         # we may trash some of the args so we take a copy
  79.         @a = @DB::args;    # must get local copy of args
  80.         # don't print any more than $MaxArgNums
  81.         if ($MaxArgNums and @a > $MaxArgNums) {
  82.             # cap the length of $#a and set the last element to '...'
  83.             $#a = $MaxArgNums;
  84.             $a[$#a] = "...";
  85.         }
  86.         for (@a) {
  87.             # set args to the string "undef" if undefined
  88.             $_ = "undef", next unless defined $_;
  89.             if (ref $_) {
  90.             # force reference to string representation
  91.             $_ .= '';
  92.             s/'/\\'/g;
  93.             }
  94.             else {
  95.             s/'/\\'/g;
  96.             # terminate the string early with '...' if too long
  97.             substr($_,$MaxArgLen) = '...'
  98.                 if $MaxArgLen and $MaxArgLen < length;
  99.             }
  100.             # 'quote' arg unless it looks like a number
  101.             $_ = "'$_'" unless /^-?[\d.]+$/;
  102.             # print high-end chars as 'M-<char>'
  103.             s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  104.             # print remaining control chars as ^<char>
  105.             s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  106.         }
  107.         # append ('all', 'the', 'arguments') to the $sub string
  108.         $sub .= '(' . join(', ', @a) . ')';
  109.         }
  110.         # here's where the error message, $mess, gets constructed
  111.         $mess .= "\t$sub " if $error eq "called";
  112.         $mess .= "$error at $file line $line";
  113.         if (defined &Thread::tid) {
  114.         my $tid = Thread->self->tid;
  115.         $mess .= " thread $tid" if $tid;
  116.         }
  117.         $mess .= "\n";
  118.     }
  119.     # we don't need to print the actual error message again so we can
  120.     # change this to "called" so that the string "$error at $file line
  121.     # $line" makes sense as "called at $file line $line".
  122.     $error = "called";
  123.     }
  124.     # this kludge circumvents die's incorrect handling of NUL
  125.     my $msg = \($mess || $error);
  126.     $$msg =~ tr/\0//d;
  127.     $$msg;
  128. }
  129.  
  130.  
  131. # ancestors() returns the complete set of ancestors of a module
  132.  
  133. sub ancestors($$);
  134.  
  135. sub ancestors($$){
  136.     my( $pack, $href ) = @_;
  137.     if( @{"${pack}::ISA"} ){
  138.     my $risa = \@{"${pack}::ISA"};
  139.     my %tree  = ();
  140.     @tree{@$risa} = ();
  141.     foreach my $mod ( @$risa ){
  142.         # visit ancestors - if not already in the gallery
  143.         if( ! defined( $$href{$mod} ) ){
  144.         my @ancs = ancestors( $mod, $href );
  145.         @tree{@ancs} = ();
  146.         }
  147.     }
  148.     return ( keys( %tree ) );
  149.     } else {
  150.     return ();
  151.     }
  152. }
  153.  
  154.  
  155. # shortmess() is called by carp() and croak() to skip all the way up to
  156. # the top-level caller's package and report the error from there.  confess()
  157. # and cluck() generate a full stack trace so they call longmess() to
  158. # generate that.  In verbose mode shortmess() calls longmess() so
  159. # you always get a stack trace
  160.  
  161. sub shortmess_heavy {    # Short-circuit &longmess if called via multiple packages
  162.     goto &longmess_heavy if $Verbose;
  163.     return @_ if ref $_[0];
  164.     my $error = join '', @_;
  165.     my ($prevpack) = caller(1);
  166.     my $extra = $CarpLevel;
  167.  
  168.     my @Clans = ( $prevpack );
  169.     my $i = 2;
  170.     my ($pack,$file,$line);
  171.     # when reporting an error, we want to report it from the context of the
  172.     # calling package.  So what is the calling package?  Within a module,
  173.     # there may be many calls between methods and perhaps between sub-classes
  174.     # and super-classes, but the user isn't interested in what happens
  175.     # inside the package.  We start by building a hash array which keeps
  176.     # track of all the packages to which the calling package belongs.  We
  177.     # do this by examining its @ISA variable.  Any call from a base class
  178.     # method (one of our caller's @ISA packages) can be ignored
  179.     my %isa;
  180.  
  181.     # merge all the caller's @ISA packages and ancestors into %isa.
  182.     my @pars = ancestors( $prevpack, \%isa );
  183.     @isa{@pars} = () if @pars;
  184.     $isa{$prevpack} = 1;
  185.  
  186.     # now we crawl up the calling stack and look at all the packages in
  187.     # there.  For each package, we look to see if it has an @ISA and then
  188.     # we see if our caller features in that list.  That would imply that
  189.     # our caller is a derived class of that package and its calls can also
  190.     # be ignored
  191. CALLER:
  192.     while (($pack,$file,$line) = caller($i++)) {
  193.  
  194.         # Chances are, the caller's caller (or its caller...) is already
  195.         # in the gallery - if so, ignore this caller.
  196.         next if exists( $isa{$pack} );
  197.  
  198.         # no: collect this module's ancestors.
  199.         my @i = ancestors( $pack, \%isa );
  200.         my %i;
  201.         if( @i ){
  202.          @i{@i} = ();
  203.             # check whether our representative of one of the clans is
  204.             # in this family tree.
  205.         foreach my $cl (@Clans){
  206.                 if( exists( $i{$cl} ) ){
  207.                     # yes: merge all of the family tree into %isa
  208.                 @isa{@i,$pack} = ();
  209.             # and here's where we do some more ignoring...
  210.             # if the package in question is one of our caller's
  211.             # base or derived packages then we can ignore it (skip it)
  212.             # and go onto the next.
  213.             next CALLER if exists( $isa{$pack} );
  214.             last;
  215.         }
  216.             }
  217.     }
  218.  
  219.     # Hey!  We've found a package that isn't one of our caller's
  220.     # clan....but wait, $extra refers to the number of 'extra' levels
  221.     # we should skip up.  If $extra > 0 then this is a false alarm.
  222.     # We must merge the package into the %isa hash (so we can ignore it
  223.     # if it pops up again), decrement $extra, and continue.
  224.     if ($extra-- > 0) {
  225.         push( @Clans, $pack );
  226.         @isa{@i,$pack} = ();
  227.     }
  228.     else {
  229.         # OK!  We've got a candidate package.  Time to construct the
  230.         # relevant error message and return it.   die() doesn't like
  231.         # to be given NUL characters (which $msg may contain) so we
  232.         # remove them first.
  233.         my $msg;
  234.         $msg = "$error at $file line $line";
  235.         if (defined &Thread::tid) {
  236.         my $tid = Thread->self->tid;
  237.         $mess .= " thread $tid" if $tid;
  238.         }
  239.         $msg .= "\n";
  240.         $msg =~ tr/\0//d;
  241.         return $msg;
  242.     }
  243.     }
  244.  
  245.     # uh-oh!  It looks like we crawled all the way up the stack and
  246.     # never found a candidate package.  Oh well, let's call longmess
  247.     # to generate a full stack trace.  We use the magical form of 'goto'
  248.     # so that this shortmess() function doesn't appear on the stack
  249.     # to further confuse longmess() about it's calling package.
  250.     goto &longmess_heavy;
  251. }
  252.  
  253. 1;
  254.