]> scm.dxcluster.org Git - spider.git/blob - perl/DXDebug.pm
add info to Changes and UPGRADE.mojo
[spider.git] / 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