git.maemo.org Git - dh-make-perl/blob - dev/i386/libwww-perl/libwww-perl-5.813/lib/LWP/DebugFile.pm

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