X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXDebug.pm;h=08703d7c8230e49b780d71821d60cbd65719a1d4;hb=refs%2Fheads%2Fnew-spawn;hp=7640a2a1cd5d594607d77932a370379d23902128;hpb=d339a58bd419901bf4294aaa138c000a8c2ae139;p=spider.git diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm index 7640a2a1..08703d7c 100644 --- a/perl/DXDebug.pm +++ b/perl/DXDebug.pm @@ -2,26 +2,36 @@ # The system variables - those indicated will need to be changed to suit your # circumstances (and callsign) # -# Copyright (c) 1998 - Dirk Koopman G1TLH +# Copyright (c) 1998-2019 - Dirk Koopman G1TLH # -# $Id$ +# Note: Everything is recorded into the ring buffer (in perl terms: a numerically max sized array). +# To allow debugging of a category (e.g. 'chan') but not onto disc (just into the ring buffer) +# do: set/debug chan nologchan # package DXDebug; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(dbginit dbgstore dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck cluck); +@EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck); use strict; -use vars qw(%dbglevel $fp); +use vars qw(%dbglevel $fp $callback $cleandays $keepdays $dbgringlth); use DXUtil; use DXLog (); -use Carp qw(cluck); +use Carp (); +use POSIX qw(isatty); %dbglevel = (); $fp = undef; +$callback = undef; +$keepdays = 10; +$cleandays = 100; +$dbgringlth = 500; + +our $no_stdout; # set if not running in a terminal +our @dbgring; # Avoid generating "subroutine redefined" warnings with the following # hack (from CGI::Carp): @@ -29,72 +39,110 @@ if (!defined $DB::VERSION) { local $^W=0; eval qq( sub confess { \$SIG{__DIE__} = 'DEFAULT'; - DXDebug::dbgstore(\$@, Carp::shortmess(\@_)); + DXDebug::dbgprintring() unless DXDebug::isdbg('chan'); + DXDebug::dbgclearring(); + DXDebug::dbg(\$@); + DXDebug::dbg(Carp::shortmess(\@_)); exit(-1); } sub croak { \$SIG{__DIE__} = 'DEFAULT'; - DXDebug::dbgstore(\$@, Carp::longmess(\@_)); + DXDebug::dbgprintring() unless DXDebug::isdbg('chan'); + DXDebug::dbgclearring(); + DXDebug::dbg(\$@); + DXDebug::dbg(Carp::longmess(\@_)); exit(-1); } - sub carp { DXDebug::dbgstore(Carp::shortmess(\@_)); } - sub cluck { DXDebug::dbgstore(Carp::longmess(\@_)); } + sub carp { DXDebug::dbg(Carp::shortmess(\@_)); } + sub cluck { DXDebug::dbg(Carp::longmess(\@_)); } ); CORE::die(Carp::shortmess($@)) if $@; -} else { - eval qq( sub confess { Carp::confess(\@_); }; - sub cluck { Carp::cluck(\@_); }; +} +else { + eval qq( sub confess { die Carp::longmess(\@_); }; + sub croak { die Carp::shortmess(\@_); }; + sub cluck { warn Carp::longmess(\@_); }; + sub carp { warn Carp::shortmess(\@_); }; ); } -sub dbgstore +my $_isdbg; # current dbg level we are processing + +sub dbg($) { + return unless $fp; my $t = time; for (@_) { my $r = $_; chomp $r; my @l = split /\n/, $r; for (@l) { - s/([\x00\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg; - print "$_\n" if defined \*STDOUT; - $fp->writeunix($t, "$t^$_"); + s/([\x00-\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg; + print "$_\n" if defined \*STDOUT && !$no_stdout; + my $str = "$t^$_"; + &$callback($str) if $callback; + if ($dbgringlth) { + shift @dbgring while (@dbgring > $dbgringlth); + push @dbgring, $str; + } + $fp->writeunix($t, $str) unless $dbglevel{"nolog$_isdbg"}; } } + $_isdbg = ''; } sub dbginit { + $callback = shift; + # add sig{__DIE__} handling - if (!defined $DB::VERSION) { - $SIG{__WARN__} = sub { dbgstore($@, Carp::shortmess(@_)); }; - $SIG{__DIE__} = sub { dbgstore($@, Carp::longmess(@_)); }; + unless (defined $DB::VERSION) { + $SIG{__WARN__} = sub { + if ($_[0] =~ /Deep\s+recursion/i) { + dbg($@); + dbg(Carp::longmess(@_)); + CORE::die; + } + else { + dbg($@); + dbg(Carp::shortmess(@_)); + } + }; + + $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); }; + + # switch off STDOUT printing if we are not talking to a TTY + unless ($^O =~ /^MS/ || $^O =~ /^OS-2/) { + unless (isatty(STDOUT->fileno)) { + ++$no_stdout; + } + } } $fp = DXLog::new('debug', 'dat', 'd'); + dbgclearring(); } sub dbgclose { $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT'; - $fp->close() if $fp; - undef $fp; -} - -sub dbg -{ - my $l = shift; - if ($fp && ($dbglevel{$l} || $l eq 'err')) { - dbgstore(@_); + if ($fp) { + dbgprintring() if grep /nolog/, keys %dbglevel; + $fp->close(); } + dbgclearring(); + undef $fp; } sub dbgdump { + return unless $fp; + my $l = shift; my $m = shift; - if ($fp && ($dbglevel{$l} || $l eq 'err')) { + if ($dbglevel{$l} || $l eq 'err') { foreach my $l (@_) { for (my $o = 0; $o < length $l; $o += 16) { my $c = substr $l, $o, 16; @@ -102,7 +150,7 @@ sub dbgdump $c =~ s/[\x00-\x1f\x7f-\xff]/./g; my $left = 16 - length $c; $h .= ' ' x (2 * $left) if $left > 0; - dbgstore($m . sprintf("%4d:", $o) . "$h $c"); + dbg($m . sprintf("%4d:", $o) . "$h $c"); $m = ' ' x (length $m); } } @@ -132,10 +180,13 @@ sub dbglist return keys (%dbglevel); } -sub isdbg +sub isdbg($) { - my $s = shift; - return $dbglevel{$s}; + return unless $fp; + if ($dbglevel{$_[0]}) { + $_isdbg = $_[0]; + return 1; + } } sub shortmess @@ -144,10 +195,57 @@ sub shortmess } sub longmess -{ +{ return Carp::longmess(@_); } +sub dbgprintring +{ + return unless $fp; + my $first; + while (my $l = shift @dbgring) { + my ($t, $str) = split /\^/, $l, 2; + next unless $t; + my $lt = time; + unless ($first) { + $fp->writeunix($lt, "$lt^###"); + $fp->writeunix($lt, "$lt^### RINGBUFFER START"); + $fp->writeunix($lt, "$lt^###"); + $first = $t; + } + my $buf = sprintf "%02d:%02d:%02d", (gmtime($t))[2,1,0]; + $fp->writeunix($lt, "$lt^RING: $buf^$str"); + } + my $et = time; + $fp->writeunix($et, "$et^###"); + $fp->writeunix($et, "$et^### RINGBUFFER END"); + $fp->writeunix($et, "$et^###"); +} + +sub dbgclearring +{ + @dbgring = (); +} + +# clean out old debug files, stop when you get a gap of more than a month +sub dbgclean +{ + my $date = $fp->unixtoj($main::systime)->sub($keepdays+1); + my $i = 0; + + while ($i < 31) { + my $fn = $fp->_genfn($date); + if (-e $fn) { + unlink $fn; + $i = 0; + } + else { + $i++; + } + $date = $date->sub(1); + } +} + 1; __END__