home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _a857722c284075eae3165a774c4a4e46 < prev    next >
Encoding:
Text File  |  2000-03-15  |  3.2 KB  |  130 lines
  1. #!/usr/local/bin/perl -w
  2. #
  3. # $Id: Debug.pm,v 1.12 1997/12/02 13:22:52 aas Exp $
  4. #
  5. package LWP::Debug;
  6.  
  7. =head1 NAME
  8.  
  9. LWP::Debug - debug routines for the libwww-perl library
  10.  
  11. =head1 SYNOPSIS
  12.  
  13.  use LWP::Debug qw(+ -conns);
  14.  
  15.  # Used internally in the library
  16.  LWP::Debug::trace('send()');
  17.  LWP::Debug::debug('url ok');
  18.  LWP::Debug::conns("read $n bytes: $data");
  19.  
  20. =head1 DESCRIPTION
  21.  
  22. LWP::Debug provides tracing facilities. The trace(), debug() and
  23. conns() function are called within the library and they log
  24. information at increasing levels of detail. Which level of detail is
  25. actually printed is controlled with the C<level()> function.
  26.  
  27. The following functions are available:
  28.  
  29. =over 4
  30.  
  31. =item level(...)
  32.  
  33. The C<level()> function controls the level of detail being
  34. logged. Passing '+' or '-' indicates full and no logging
  35. respectively. Inidividual levels can switched on and of by passing the
  36. name of the level with a '+' or '-' prepended.  The levels are:
  37.  
  38.   trace   : trace function calls
  39.   debug   : print debug messages
  40.   conns   : show all data transfered over the connections
  41.  
  42. The LWP::Debug module provide a special import() method that allows
  43. you to pass the level() arguments with initial use statement.  If a
  44. use argument start with '+' or '-' then it is passed to the level
  45. function, else the name is exported as usual.  The following two
  46. statements are thus equivalent (if you ignore that the second pollutes
  47. your namespace):
  48.  
  49.   use LWP::Debug qw(+);
  50.   use LWP::Debug qw(level); level('+');
  51.  
  52. =item trace($msg)
  53.  
  54. The C<trace()> function is used for tracing function
  55. calls. The package and calling subroutine name is
  56. printed along with the passed argument. This should
  57. be called at the start of every major function.
  58.  
  59. =item debug($msg)
  60.  
  61. The C<debug()> function is used for high-granularity
  62. reporting of state in functions.
  63.  
  64. =item conns($msg)
  65.  
  66. The C<conns()> function is used to show data being
  67. transferred over the connections. This may generate
  68. considerable output.
  69.  
  70. =back
  71.  
  72. =cut
  73.  
  74. require Exporter;
  75. @ISA = qw(Exporter);
  76. @EXPORT_OK = qw(level trace debug conns);
  77.  
  78. use Carp ();
  79.  
  80. my @levels = qw(trace debug conns);
  81. %current_level = ();
  82.  
  83. sub import
  84. {
  85.     my $pack = shift;
  86.     my $callpkg = caller(0);
  87.     my @symbols = ();
  88.     my @levels = ();
  89.     for (@_) {
  90.     if (/^[-+]/) {
  91.         push(@levels, $_);
  92.     } else {
  93.         push(@symbols, $_);
  94.     }
  95.     }
  96.     Exporter::export($pack, $callpkg, @symbols);
  97.     level(@levels);
  98. }
  99.  
  100. sub level
  101. {
  102.     for (@_) {
  103.     if ($_ eq '+') {              # all on
  104.         # switch on all levels
  105.         %current_level = map { $_ => 1 } @levels;
  106.     } elsif ($_ eq '-') {           # all off
  107.         %current_level = ();
  108.     } elsif (/^([-+])(\w+)$/) {
  109.         $current_level{$2} = $1 eq '+';
  110.     } else {
  111.         Carp::croak("Illegal level format $_");
  112.     }
  113.     }
  114. }
  115.  
  116. sub trace  { _log(@_) if $current_level{'trace'}; }
  117. sub debug  { _log(@_) if $current_level{'debug'}; }
  118. sub conns  { _log(@_) if $current_level{'conns'}; }
  119.  
  120. sub _log
  121. {
  122.     my $msg = shift;
  123.     $msg .= "\n" unless $msg =~ /\n$/;  # ensure trailing "\n"
  124.  
  125.     my($package,$filename,$line,$sub) = caller(2);
  126.     print STDERR "$sub: $msg";
  127. }
  128.  
  129. 1;
  130.