perl/DXDebug.pm

   1 #
   2 # The system variables - those indicated will need to be changed to suit your
   3 # circumstances (and callsign)
   4 #
   5 # Copyright (c) 1998 - Dirk Koopman G1TLH
   6 #
   7 # $Id$
   8 #
   9
  10 package DXDebug;
  11
  12 require Exporter;
  13 @ISA = qw(Exporter);
  14 @EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck);
  15
  16 use strict;
  17 use vars qw(%dbglevel $fp $callback $cleandays $keepdays);
  18
  19 use DXUtil;
  20 use DXLog ();
  21 use Carp ();
  22
  23 %dbglevel = ();
  24 $fp = undef;
  25 $callback = undef;
  26 $keepdays = 10;
  27 $cleandays = 100;
  28
  29 use vars qw($VERSION $BRANCH);
  30 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  31 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0;
  32 $main::build += $VERSION;
  33 $main::branch += $BRANCH;
  34
  35 # Avoid generating "subroutine redefined" warnings with the following
  36 # hack (from CGI::Carp):
  37 if (!defined $DB::VERSION) {
  38         local $^W=0;
  39         eval qq( sub confess {
  40             \$SIG{__DIE__} = 'DEFAULT';
  41         DXDebug::dbg(\$@);
  42                 DXDebug::dbg(Carp::shortmess(\@_));
  43             exit(-1);
  44         }
  45         sub croak {
  46                 \$SIG{__DIE__} = 'DEFAULT';
  47         DXDebug::dbg(\$@);
  48                 DXDebug::dbg(Carp::longmess(\@_));
  49                 exit(-1);
  50         }
  51         sub carp    { DXDebug::dbg(Carp::shortmess(\@_)); }
  52         sub cluck   { DXDebug::dbg(Carp::longmess(\@_)); }
  53         );
  54
  55     CORE::die(Carp::shortmess($@)) if $@;
  56 } else {
  57     eval qq( sub confess { die Carp::longmess(\@_); };
  58                          sub croak { die Carp::shortmess(\@_); };
  59                          sub cluck { warn Carp::longmess(\@_); };
  60                          sub carp { warn Carp::shortmess(\@_); };
  61    );
  62 }
  63
  64
  65 sub dbg($)
  66 {
  67         return unless $fp;
  68         my $t = time;
  69         for (@_) {
  70                 my $r = $_;
  71                 chomp $r;
  72                 my @l = split /\n/, $r;
  73                 for (@l) {
  74                         s/([\x00-\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
  75                         print "$_\n" if defined \*STDOUT;
  76                         my $str = "$t^$_";
  77                         &$callback($str) if $callback;
  78                         $fp->writeunix($t, $str);
  79                 }
  80         }
  81 }
  82
  83 sub dbginit
  84 {
  85         $callback = shift;
  86
  87         # add sig{__DIE__} handling
  88         if (!defined $DB::VERSION) {
  89                 $SIG{__WARN__} = sub {
  90                         if ($_[0] =~ /Deep\s+recursion/i) {
  91                                 dbg($@);
  92                                 dbg(Carp::longmess(@_));
  93                                 CORE::die;
  94                         } else {
  95                                 dbg($@);
  96                                 dbg(Carp::shortmess(@_));
  97                         }
  98                 };
  99
 100                 $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); };
 101         }
 102
 103         $fp = DXLog::new('debug', 'dat', 'd');
 104 }
 105
 106 sub dbgclose
 107 {
 108         $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT';
 109         $fp->close() if $fp;
 110         undef $fp;
 111 }
 112
 113 sub dbgdump
 114 {
 115         my $l = shift;
 116         my $m = shift;
 117         if ($fp && ($dbglevel{$l} || $l eq 'err')) {
 118                 foreach my $l (@_) {
 119                         for (my $o = 0; $o < length $l; $o += 16) {
 120                                 my $c = substr $l, $o, 16;
 121                                 my $h = unpack "H*", $c;
 122                                 $c =~ s/[\x00-\x1f\x7f-\xff]/./g;
 123                                 my $left = 16 - length $c;
 124                                 $h .= ' ' x (2 * $left) if $left > 0;
 125                                 dbg($m . sprintf("%4d:", $o) . "$h $c");
 126                                 $m = ' ' x (length $m);
 127                         }
 128                 }
 129         }
 130 }
 131
 132 sub dbgadd
 133 {
 134         my $entry;
 135
 136         foreach $entry (@_) {
 137                 $dbglevel{$entry} = 1;
 138         }
 139 }
 140
 141 sub dbgsub
 142 {
 143         my $entry;
 144
 145         foreach $entry (@_) {
 146                 delete $dbglevel{$entry};
 147         }
 148 }
 149
 150 sub dbglist
 151 {
 152         return keys (%dbglevel);
 153 }
 154
 155 sub isdbg($)
 156 {
 157         return unless $fp;
 158         return $dbglevel{$_[0]};
 159 }
 160
 161 sub shortmess
 162 {
 163         return Carp::shortmess(@_);
 164 }
 165
 166 sub longmess
 167 {
 168         return Carp::longmess(@_);
 169 }
 170
 171 # clean out old debug files, stop when you get a gap of more than a month
 172 sub dbgclean
 173 {
 174         my $date = $fp->unixtoj($main::systime)->sub($keepdays+1);
 175         my $i = 0;
 176
 177         while ($i < 31) {
 178                 my $fn = $fp->_genfn($date);
 179                 if (-e $fn) {
 180                         unlink $fn;
 181                         $i = 0;
 182                 } else {
 183                         $i++;
 184                 }
 185                 $date = $date->sub(1);
 186         }
 187 }
 188
 189 1;
 190 __END__
 191
 192
 193
 194
 195
 196
 197