2 # The system variables - those indicated will need to be changed to suit your
3 # circumstances (and callsign)
5 # Copyright (c) 1998-2019 - Dirk Koopman G1TLH
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
16 @EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck);
19 use vars qw(%dbglevel $fp $callback $cleandays $keepdays $dbgringlth);
33 our $no_stdout; # set if not running in a terminal
36 # Avoid generating "subroutine redefined" warnings with the following
37 # hack (from CGI::Carp):
38 if (!defined $DB::VERSION) {
40 eval qq( sub confess {
41 \$SIG{__DIE__} = 'DEFAULT';
42 DXDebug::dbgprintring() unless DXDebug::isdbg('chan');
43 DXDebug::dbgclearring();
45 DXDebug::dbg(Carp::shortmess(\@_));
49 \$SIG{__DIE__} = 'DEFAULT';
50 DXDebug::dbgprintring() unless DXDebug::isdbg('chan');
51 DXDebug::dbgclearring();
53 DXDebug::dbg(Carp::longmess(\@_));
56 sub carp { DXDebug::dbg(Carp::shortmess(\@_)); }
57 sub cluck { DXDebug::dbg(Carp::longmess(\@_)); }
60 CORE::die(Carp::shortmess($@)) if $@;
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(\@_); };
71 my $_isdbg; # current dbg level we are processing
80 my @l = split /\n/, $r;
82 s/([\x00-\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
83 print "$_\n" if defined \*STDOUT && !$no_stdout;
85 &$callback($str) if $callback;
87 shift @dbgring while (@dbgring > $dbgringlth);
90 $fp->writeunix($t, $str) unless $dbglevel{"nolog$_isdbg"};
100 # add sig{__DIE__} handling
101 unless (defined $DB::VERSION) {
102 $SIG{__WARN__} = sub {
103 if ($_[0] =~ /Deep\s+recursion/i) {
105 dbg(Carp::longmess(@_));
110 dbg(Carp::shortmess(@_));
114 $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); };
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)) {
124 $fp = DXLog::new('debug', 'dat', 'd');
130 $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT';
132 dbgprintring() if grep /nolog/, keys %dbglevel;
145 if ($dbglevel{$l} || $l eq 'err') {
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);
164 foreach $entry (@_) {
165 $dbglevel{$entry} = 1;
173 foreach $entry (@_) {
174 delete $dbglevel{$entry};
180 return keys (%dbglevel);
186 if ($dbglevel{$_[0]}) {
194 return Carp::shortmess(@_);
199 return Carp::longmess(@_);
206 while (my $l = shift @dbgring) {
207 my ($t, $str) = split /\^/, $l, 2;
211 $fp->writeunix($lt, "$lt^###");
212 $fp->writeunix($lt, "$lt^### RINGBUFFER START");
213 $fp->writeunix($lt, "$lt^###");
216 my $buf = sprintf "%02d:%02d:%02d", (gmtime($t))[2,1,0];
217 $fp->writeunix($lt, "$lt^RING: $buf^$str");
220 $fp->writeunix($et, "$et^###");
221 $fp->writeunix($et, "$et^### RINGBUFFER END");
222 $fp->writeunix($et, "$et^###");
230 # clean out old debug files, stop when you get a gap of more than a month
233 my $date = $fp->unixtoj($main::systime)->sub($keepdays+1);
237 my $fn = $fp->_genfn($date);
245 $date = $date->sub(1);