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-2019 - Dirk Koopman G1TLH
   6 #
   7 # Note: Everything is recorded into the ring buffer (in perl terms: a numerically max sized array).
   8 #       To allow debugging of a category (e.g. 'chan') but not onto disc (just into the ring buffer)
   9 #       do: set/debug chan nologchan
  10 #
  11
  12 package DXDebug;
  13
  14 require Exporter;
  15 @ISA = qw(Exporter);
  16 @EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck);
  17
  18 use strict;
  19 use vars qw(%dbglevel $fp $callback $cleandays $keepdays $dbgringlth);
  20
  21 use DXUtil;
  22 use DXLog ();
  23 use Carp ();
  24 use POSIX qw(isatty);
  25
  26 %dbglevel = ();
  27 $fp = undef;
  28 $callback = undef;
  29 $keepdays = 10;
  30 $cleandays = 100;
  31 $dbgringlth = 500;
  32
  33 our $no_stdout;                                 # set if not running in a terminal
  34 our @dbgring;
  35
  36 # Avoid generating "subroutine redefined" warnings with the following
  37 # hack (from CGI::Carp):
  38 if (!defined $DB::VERSION) {
  39         local $^W=0;
  40         eval qq( sub confess {
  41             \$SIG{__DIE__} = 'DEFAULT';
  42         DXDebug::dbgprintring() unless DXDebug::isdbg('chan');
  43         DXDebug::dbgclearring();
  44         DXDebug::dbg(\$@);
  45                 DXDebug::dbg(Carp::shortmess(\@_));
  46             exit(-1);
  47         }
  48         sub croak {
  49                 \$SIG{__DIE__} = 'DEFAULT';
  50         DXDebug::dbgprintring() unless DXDebug::isdbg('chan');
  51         DXDebug::dbgclearring();
  52         DXDebug::dbg(\$@);
  53                 DXDebug::dbg(Carp::longmess(\@_));
  54                 exit(-1);
  55         }
  56         sub carp    { DXDebug::dbg(Carp::shortmess(\@_)); }
  57         sub cluck   { DXDebug::dbg(Carp::longmess(\@_)); }
  58         );
  59
  60     CORE::die(Carp::shortmess($@)) if $@;
  61 }
  62 else {
  63     eval qq( sub confess { die Carp::longmess(\@_); };
  64                          sub croak { die Carp::shortmess(\@_); };
  65                          sub cluck { warn Carp::longmess(\@_); };
  66                          sub carp { warn Carp::shortmess(\@_); };
  67    );
  68 }
  69
  70
  71 my $_isdbg;                                             # current dbg level we are processing
  72
  73 sub dbg($)
  74 {
  75         return unless $fp;
  76         my $t = time;
  77         for (@_) {
  78                 my $r = $_;
  79                 chomp $r;
  80                 my @l = split /\n/, $r;
  81                 for (@l) {
  82                         s/([\x00-\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
  83                         print "$_\n" if defined \*STDOUT && !$no_stdout;
  84                         my $str = "$t^$_";
  85                         &$callback($str) if $callback;
  86                         if ($dbgringlth) {
  87                                 shift @dbgring while (@dbgring > $dbgringlth);
  88                                 push @dbgring, $str;
  89                         }
  90                         $fp->writeunix($t, $str) unless $dbglevel{"nolog$_isdbg"};
  91                 }
  92         }
  93         $_isdbg = '';
  94 }
  95
  96 sub dbginit
  97 {
  98         $callback = shift;
  99
 100         # add sig{__DIE__} handling
 101         unless (defined $DB::VERSION) {
 102                 $SIG{__WARN__} = sub {
 103                         if ($_[0] =~ /Deep\s+recursion/i) {
 104                                 dbg($@);
 105                                 dbg(Carp::longmess(@_));
 106                                 CORE::die;
 107                         }
 108                         else {
 109                                 dbg($@);
 110                                 dbg(Carp::shortmess(@_));
 111                         }
 112                 };
 113
 114                 $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); };
 115
 116                 # switch off STDOUT printing if we are not talking to a TTY
 117                 unless ($^O =~ /^MS/ || $^O =~ /^OS-2/) {
 118                         unless (isatty(STDOUT->fileno)) {
 119                                 ++$no_stdout;
 120                         }
 121                 }
 122         }
 123
 124         $fp = DXLog::new('debug', 'dat', 'd');
 125         dbgclearring();
 126 }
 127
 128 sub dbgclose
 129 {
 130         $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT';
 131         if ($fp) {
 132                 dbgprintring() if grep /nolog/, keys %dbglevel;
 133                 $fp->close();
 134         }
 135         dbgclearring();
 136         undef $fp;
 137 }
 138
 139 sub dbgdump
 140 {
 141         return unless $fp;
 142
 143         my $l = shift;
 144         my $m = shift;
 145         if ($dbglevel{$l} || $l eq 'err') {
 146                 foreach my $l (@_) {
 147                         for (my $o = 0; $o < length $l; $o += 16) {
 148                                 my $c = substr $l, $o, 16;
 149                                 my $h = unpack "H*", $c;
 150                                 $c =~ s/[\x00-\x1f\x7f-\xff]/./g;
 151                                 my $left = 16 - length $c;
 152                                 $h .= ' ' x (2 * $left) if $left > 0;
 153                                 dbg($m . sprintf("%4d:", $o) . "$h $c");
 154                                 $m = ' ' x (length $m);
 155                         }
 156                 }
 157         }
 158 }
 159
 160 sub dbgadd
 161 {
 162         my $entry;
 163
 164         foreach $entry (@_) {
 165                 $dbglevel{$entry} = 1;
 166         }
 167 }
 168
 169 sub dbgsub
 170 {
 171         my $entry;
 172
 173         foreach $entry (@_) {
 174                 delete $dbglevel{$entry};
 175         }
 176 }
 177
 178 sub dbglist
 179 {
 180         return keys (%dbglevel);
 181 }
 182
 183 sub isdbg($)
 184 {
 185         return unless $fp;
 186         if ($dbglevel{$_[0]}) {
 187                 $_isdbg = $_[0];
 188                 return 1;
 189     }
 190 }
 191
 192 sub shortmess
 193 {
 194         return Carp::shortmess(@_);
 195 }
 196
 197 sub longmess
 198 {
 199         return Carp::longmess(@_);
 200 }
 201
 202 sub dbgprintring
 203 {
 204         return unless $fp;
 205         my $first;
 206         while (my $l = shift @dbgring) {
 207                 my ($t, $str) = split /\^/, $l, 2;
 208                 next unless $t;
 209                 my $lt = time;
 210                 unless ($first) {
 211                         $fp->writeunix($lt, "$lt^###");
 212                         $fp->writeunix($lt, "$lt^### RINGBUFFER START");
 213                         $fp->writeunix($lt, "$lt^###");
 214                         $first = $t;
 215                 }
 216                 my $buf = sprintf "%02d:%02d:%02d", (gmtime($t))[2,1,0];
 217                 $fp->writeunix($lt, "$lt^RING: $buf^$str");
 218         }
 219         my $et = time;
 220         $fp->writeunix($et, "$et^###");
 221         $fp->writeunix($et, "$et^### RINGBUFFER END");
 222         $fp->writeunix($et, "$et^###");
 223 }
 224
 225 sub dbgclearring
 226 {
 227         @dbgring = ();
 228 }
 229
 230 # clean out old debug files, stop when you get a gap of more than a month
 231 sub dbgclean
 232 {
 233         my $date = $fp->unixtoj($main::systime)->sub($keepdays+1);
 234         my $i = 0;
 235
 236         while ($i < 31) {
 237                 my $fn = $fp->_genfn($date);
 238                 if (-e $fn) {
 239                         unlink $fn;
 240                         $i = 0;
 241                 }
 242                 else {
 243                         $i++;
 244                 }
 245                 $date = $date->sub(1);
 246         }
 247 }
 248
 249 1;
 250 __END__
 251
 252
 253
 254
 255
 256
 257