home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Clan.pm < prev    next >
Encoding:
Text File  |  2003-08-19  |  7.5 KB  |  220 lines
  1.  
  2. ##
  3. ## Based on Carp.pm from Perl 5.005_03.
  4. ## Last modified 12-Jun-2001 by Steffen Beyer.
  5. ## Should be reasonably backwards compatible.
  6. ##
  7. ## This module is free software and can
  8. ## be used, modified and redistributed
  9. ## under the same terms as Perl itself.
  10. ##
  11.  
  12. @DB::args = (); # Avoid warning "used only once" in Perl 5.003
  13.  
  14. package Carp::Clan;
  15.  
  16. use strict;
  17. use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION );
  18.  
  19. # Original comments by Andy Wardley <abw@kfs.org> 09-Apr-1998.
  20.  
  21. # The $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how
  22. # the eval text and function arguments should be formatted when printed.
  23.  
  24. $MaxEvalLen =  0;   # How much eval '...text...' to show. 0 = all.
  25. $MaxArgLen  = 64;   # How much of each argument to print. 0 = all.
  26. $MaxArgNums =  8;   # How many arguments to print.        0 = all.
  27.  
  28. $Verbose = 0;       # If true then make _shortmsg call _longmsg instead.
  29.  
  30. $VERSION = '5.1';
  31.  
  32. # _longmsg() crawls all the way up the stack reporting on all the function
  33. # calls made. The error string, $error, is originally constructed from the
  34. # arguments passed into _longmsg() via confess(), cluck() or _shortmsg().
  35. # This gets appended with the stack trace messages which are generated for
  36. # each function call on the stack.
  37.  
  38. sub _longmsg
  39. {
  40.     return(@_) if (ref $_[0]);
  41.     local $^W = 0; # For cases when overloaded stringify returns undef
  42.     local $_;      # Protect surrounding program - just in case...
  43.     my($pack,$file,$line,$sub,$hargs,$eval,$require,@parms,$push);
  44.     my $error = join('', @_);
  45.     my $msg = '';
  46.     my $i = 0;
  47.     while ( do { { package DB; ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = caller($i++) } } )
  48.     {
  49.         next if ($pack eq 'Carp::Clan');
  50.         if ($error eq '')
  51.         {
  52.             if (defined $eval)
  53.             {
  54.                 $eval =~ s/([\\\'])/\\$1/g unless ($require); # Escape \ and '
  55.                 $eval =~ s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
  56.                 substr($eval,$MaxEvalLen) = '...' if ($MaxEvalLen && length($eval) > $MaxEvalLen);
  57.                 if ($require)        { $sub = "require $eval"; }
  58.                 else                 { $sub = "eval '$eval'";  }
  59.             }
  60.             elsif ($sub eq '(eval)') { $sub = 'eval {...}';    }
  61.             else
  62.             {
  63.                 @parms = ();
  64.                 if ($hargs)
  65.                 {
  66.                     $push = 0;
  67.                     @parms = @DB::args; # We may trash some of the args so we take a copy
  68.                     if ($MaxArgNums and @parms > $MaxArgNums)
  69.                     {
  70.                         $#parms = $MaxArgNums;
  71.                         pop(@parms);
  72.                         $push = 1;
  73.                     }
  74.                     for (@parms)
  75.                     {
  76.                         if (defined $_)
  77.                         {
  78.                             if (ref $_)
  79.                             {
  80.                                 $_ = "$_"; # Beware of overloaded objects!
  81.                             }
  82.                             else
  83.                             {
  84.                                 unless (/^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/) # Looks numeric
  85.                                 {
  86.                                     s/([\\\'])/\\$1/g; # Escape \ and '
  87.                                     s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
  88.                                     substr($_,$MaxArgLen) = '...' if ($MaxArgLen and length($_) > $MaxArgLen);
  89.                                     $_ = "'$_'";
  90.                                 }
  91.                             }
  92.                         }
  93.                         else { $_ = 'undef'; }
  94.                     }
  95.                     push(@parms, '...') if ($push);
  96.                 }
  97.                 $sub .= '(' . join(', ', @parms) . ')';
  98.             }
  99.             if ($msg eq '') { $msg = "$sub called"; }
  100.             else            { $msg .= "\t$sub called"; }
  101.         }
  102.         else
  103.         {
  104.             if ($sub =~ /::/) { $msg = "$sub(): $error"; }
  105.             else              { $msg = "$sub: $error";   }
  106.         }
  107.         $msg .= " at $file line $line\n" unless ($error =~ /\n$/);
  108.         $error = '';
  109.     }
  110.     $msg ||= $error;
  111.     $msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
  112.     $msg;
  113. }
  114.  
  115. # _shortmsg() is called by carp() and croak() to skip all the way up to
  116. # the top-level caller's package and report the error from there. confess()
  117. # and cluck() generate a full stack trace so they call _longmsg() to
  118. # generate that. In verbose mode _shortmsg() calls _longmsg() so you
  119. # always get a stack trace.
  120.  
  121. sub _shortmsg
  122. {
  123.     my $pattern = shift;
  124.     my $verbose = shift;
  125.     return(@_) if (ref $_[0]);
  126.     goto &_longmsg if ($Verbose or $verbose);
  127.     my($pack,$file,$line,$sub);
  128.     my $error = join('', @_);
  129.     my $msg = '';
  130.     my $i = 0;
  131.     while (($pack,$file,$line,$sub) = caller($i++))
  132.     {
  133.         next if ($pack eq 'Carp::Clan' or $pack =~ /$pattern/);
  134.         if    ($error eq '') { $msg = "$sub() called";  }
  135.         elsif ($sub =~ /::/) { $msg = "$sub(): $error"; }
  136.         else                 { $msg = "$sub: $error";   }
  137.         $msg .= " at $file line $line\n" unless ($error =~ /\n$/);
  138.         $msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
  139.         return $msg;
  140.     }
  141.     goto &_longmsg;
  142. }
  143.  
  144. # The following four functions call _longmsg() or _shortmsg() depending on
  145. # whether they should generate a full stack trace (confess() and cluck())
  146. # or simply report the caller's package (croak() and carp()), respectively.
  147. # confess() and croak() die, carp() and cluck() warn.
  148.  
  149. # Following code kept for calls with fully qualified subroutine names:
  150. # (For backward compatibility with the original Carp.pm)
  151.  
  152. sub croak
  153. {
  154.     my $callpkg = caller(0);
  155.     my $pattern = ($callpkg eq 'main') ? '^:::' : "^$callpkg\$";
  156.     die _shortmsg($pattern, 0, @_);
  157. }
  158. sub confess { die _longmsg(@_); }
  159. sub carp
  160. {
  161.     my $callpkg = caller(0);
  162.     my $pattern = ($callpkg eq 'main') ? '^:::' : "^$callpkg\$";
  163.     warn _shortmsg($pattern, 0, @_);
  164. }
  165. sub cluck { warn _longmsg(@_); }
  166.  
  167. # The following method imports a different closure for every caller.
  168. # I.e., different modules can use this module at the same time
  169. # and in parallel and still use different patterns.
  170.  
  171. sub import
  172. {
  173.     my $pkg     = shift;
  174.     my $callpkg = caller(0);
  175.     my $pattern = ($callpkg eq 'main') ? '^:::' : "^$callpkg\$";
  176.     my $verbose = 0;
  177.     my $item;
  178.     my $file;
  179.  
  180.     for $item (@_)
  181.     {
  182.         if ($item =~ /^\d/)
  183.         {
  184.             if ($VERSION < $item)
  185.             {
  186.                 $file = "$pkg.pm";
  187.                 $file =~ s!::!/!g;
  188.                 $file = $INC{$file};
  189.                 die _shortmsg('^:::', 0, "$pkg $item required--this is only version $VERSION ($file)");
  190.             }
  191.         }
  192.         elsif ($item =~ /^verbose$/i) { $verbose = 1;     }
  193.         else                          { $pattern = $item; }
  194.     }
  195.     # Speed up pattern matching in Perl versions >= 5.005:
  196.     # (Uses "eval ''" because qr// is a syntax error in previous Perl versions)
  197.     if ($] >= 5.005)
  198.     {
  199.         eval '$pattern = qr/$pattern/;';
  200.     }
  201.     else
  202.     {
  203.         eval { $pkg =~ /$pattern/; };
  204.     }
  205.     if ($@)
  206.     {
  207.         $@ =~ s/\s+$//;
  208.         $@ =~ s/\s+at\s.+$//;
  209.         die _shortmsg('^:::', 0, $@);
  210.     }
  211.     no strict "refs";
  212.     *{"${callpkg}::croak"}   = sub { die  _shortmsg($pattern, $verbose, @_); };
  213.     *{"${callpkg}::confess"} = sub { die  _longmsg (                    @_); };
  214.     *{"${callpkg}::carp"}    = sub { warn _shortmsg($pattern, $verbose, @_); };
  215.     *{"${callpkg}::cluck"}   = sub { warn _longmsg (                    @_); };
  216. }
  217.  
  218. 1;
  219.  
  220.