home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _1952727e30e00ee729f3a220afd37965 < prev    next >
Encoding:
Text File  |  2004-06-01  |  6.5 KB  |  223 lines
  1. package LWP::DebugFile;
  2.  
  3. # $Id: DebugFile.pm,v 1.3 2003/10/23 18:56:01 uid39246 Exp $
  4.  
  5. use strict;
  6. use LWP::Debug ();
  7.  
  8. use vars qw($outname $outpath @ISA $last_message_time);
  9. @ISA = ('LWP::Debug');
  10.  
  11. _init() unless $^C or !caller;
  12. $LWP::Debug::current_level{'conns'} = 1;
  13.  
  14.  
  15.  
  16. sub _init {
  17.   $outpath = $ENV{'LWPDEBUGPATH'} || ''
  18.    unless defined $outpath;
  19.   $outname = $ENV{'LWPDEBUGFILE'} ||
  20.     sprintf "%slwp_%x_%x.log", $outpath, $^T,
  21.      defined( &Win32::GetTickCount )
  22.       ? (Win32::GetTickCount() & 0xFFFF)
  23.       : $$
  24.         # Using $$ under Win32 isn't nice, because the OS usually
  25.         # reuses the $$ value almost immediately!!  So the lower
  26.         # 16 bits of the uptime tick count is a great substitute.
  27.    unless defined $outname;
  28.  
  29.   open LWPERR, ">>$outname" or die "Can't write-open $outname: $!";
  30.   # binmode(LWPERR);
  31.   {
  32.     no strict;
  33.     my $x = select(LWPERR);
  34.     ++$|;
  35.     select($x);
  36.   }
  37.  
  38.   $last_message_time = time();
  39.   die "Can't print to LWPERR"
  40.    unless print LWPERR "\n# ", __PACKAGE__, " logging to $outname\n";
  41.    # check at least the first print, just for sanity's sake!
  42.  
  43.   print LWPERR "# Time now: \{$last_message_time\} = ",
  44.           scalar(localtime($last_message_time)), "\n";
  45.  
  46.   LWP::Debug::level($ENV{'LWPDEBUGLEVEL'} || '+');
  47.   return;
  48. }
  49.  
  50.  
  51. BEGIN { # So we don't get redefinition warnings...
  52.   undef &LWP::Debug::conns;
  53.   undef &LWP::Debug::_log;
  54. }
  55.  
  56.  
  57. sub LWP::Debug::conns {
  58.   if($LWP::Debug::current_level{'conns'}) {
  59.     my $msg = $_[0];
  60.     my $line;
  61.     my $prefix = '0';
  62.     while($msg =~ m/([^\n\r]*[\n\r]*)/g) {
  63.       next unless length($line = $1);
  64.       # Hex escape it:
  65.       $line =~ s/([^\x20\x21\x23-\x7a\x7c\x7e])/
  66.         (ord($1)<256) ? sprintf('\x%02X',ord($1))
  67.          : sprintf('\x{%x}',ord($1))
  68.       /eg;
  69.       LWP::Debug::_log("S>$prefix \"$line\"");
  70.       $prefix = '+';
  71.     }
  72.   }
  73. }
  74.  
  75.  
  76. sub LWP::Debug::_log
  77. {
  78.     my $msg = shift;
  79.     $msg .= "\n" unless $msg =~ /\n$/;  # ensure trailing "\n"
  80.  
  81.     my($package,$filename,$line,$sub) = caller(2);
  82.     unless((my $this_time = time()) == $last_message_time) {
  83.       print LWPERR "# Time now: \{$this_time\} = ",
  84.         scalar(localtime($this_time)), "\n";
  85.       $last_message_time = $this_time;
  86.     }
  87.     print LWPERR "$sub: $msg";
  88. }
  89.  
  90.  
  91. 1;
  92.  
  93. __END__
  94.  
  95. =head1 NAME
  96.  
  97. LWP::DebugFile - routines for tracing/debugging LWP
  98.  
  99. =head1 SYNOPSIS
  100.  
  101. If you want to see just what LWP is doing when your program calls it,
  102. add this to the beginning of your program's source:
  103.  
  104.   use LWP::DebugFile;
  105.  
  106. For even more verbose debug output, do this instead:
  107.  
  108.   use LWP::DebugFile ('+');
  109.  
  110. =head1 DESCRIPTION
  111.  
  112. This module is like LWP::Debug in that it allows you to see what your
  113. calls to LWP are doing behind the scenes.  But it is unlike
  114. L<LWP::Debug|LWP::Debug> in that it sends the output to a file, instead
  115. of to STDERR (as LWP::Debug does).
  116.  
  117. =head1 OPTIONS
  118.  
  119. The options you can use in C<use LWP::DebugFile (I<options>)> are the
  120. same as the B<non-exporting> options available from C<use LWP::Debug
  121. (I<options>)>.  That is, you can do things like this:
  122.  
  123.   use LWP::DebugFile qw(+);
  124.   use LWP::Debug qw(+ -conns);
  125.   use LWP::Debug qw(trace);
  126.  
  127. The meanings of these are explained in the
  128. L<documentation for LWP::Debug|LWP::Debug>.
  129. The only differences are that by default, LWP::DebugFile has C<cons>
  130. debugging on, ad that (as mentioned earlier), only C<non-exporting>
  131. options are available.  That is, you B<can't> do this:
  132.  
  133.   use LWP::DebugFile qw(trace); # wrong
  134.  
  135. You might expect that to export LWP::Debug's C<trace()> function,
  136. but it doesn't work -- it's a compile-time error.
  137.  
  138. =head1 OUTPUT FILE NAMING
  139.  
  140. If you don't do anything, the output file (where all the LWP debug/trace
  141. output goes) will be in the current directory, and will be named like
  142. F<lwp_3db7aede_b93.log>, where I<3db7aede> is C<$^T> expressed in hex,
  143. and C<b93> is C<$$> expressed in hex.  Presumably this is a
  144. unique-for-all-time filename!
  145.  
  146. If you don't want the files to go in the current directory, you
  147. can set C<$LWP::DebugFile::outpath> before you load the LWP::DebugFile
  148. module:
  149.  
  150.   BEGIN { $LWP::DebugFile::outpath = '/tmp/crunk/' }
  151.   use LWP::DebugFile;
  152.  
  153. Note that you must end the value with a path separator ("/" in this
  154. case -- under MacPerl it would be ":").  With that set, you will
  155. have output files named like F</tmp/crunk/lwp_3db7aede_b93.log>.
  156.  
  157. If you want the LWP::DebugFile output to go a specific filespec (instead
  158. of just a uniquely named file, in whatever directory), instead set the
  159. variable C<$LWP::DebugFile::outname>, like so:
  160.  
  161.   BEGIN { $LWP::DebugFile::outname = '/home/mojojojo/lwp.log' }
  162.   use LWP::DebugFile;
  163.  
  164. In that case, C<$LWP::DebugFile::outpath> isn't consulted at all, and
  165. output is always written to the file F</home/mojojojo/lwp.log>.
  166.  
  167. Note that the value of C<$LWP::DebugFile::outname> doesn't need to
  168. be an absolute filespec.  You can do this:
  169.  
  170.   BEGIN { $LWP::DebugFile::outname = 'lwp.log' }
  171.   use LWP::DebugFile;
  172.  
  173. In that case, output goes to a file named F<lwp.log> in the current
  174. directory -- specifically, whatever directory is current when
  175. LWP::DebugFile is first loaded. C<$LWP::DebugFile::outpath> is still not
  176. consulted -- its value is used only if C<$LWP::DebugFile::outname>
  177. isn't set.
  178.  
  179.  
  180. =head1 ENVIRONMENT
  181.  
  182. If you set the environment variables C<LWPDEBUGPATH> or 
  183. C<LWPDEBUGFILE>, their values will be used in initializing the
  184. values of C<$LWP::DebugFile::outpath>
  185. and C<$LWP::DebugFile::outname>.
  186.  
  187. That is, if you have C<LWPDEBUGFILE> set to F</home/mojojojo/lwp.log>,
  188. then you can just start out your program with:
  189.  
  190.   use LWP::DebugFile;
  191.  
  192. and it will act as if you had started it like this:
  193.  
  194.   BEGIN { $LWP::DebugFile::outname = '/home/mojojojo/lwp.log' }
  195.   use LWP::DebugFile;
  196.  
  197. =head1 IMPLEMENTATION NOTES
  198.  
  199. This module works by subclassing C<LWP::Debug>, (notably inheriting its
  200. C<import>). It also redefines C<&LWP::Debug::conns> and
  201. C<&LWP::Debug::_log> to make for output that is a little more verbose,
  202. and friendlier for when you're looking at it later in a log file.
  203.  
  204. =head1 SEE ALSO
  205.  
  206. L<LWP::Debug>
  207.  
  208. =head1 COPYRIGHT AND DISCLAIMERS
  209.  
  210. Copyright (c) 2002 Sean M. Burke.
  211.  
  212. This library is free software; you can redistribute it and/or modify it
  213. under the same terms as Perl itself.
  214.  
  215. This program is distributed in the hope that it will be useful, but
  216. without any warranty; without even the implied warranty of
  217. merchantability or fitness for a particular purpose.
  218.  
  219. =head1 AUTHOR
  220.  
  221. Sean M. Burke C<sburke@cpan.org>
  222.  
  223.