]> gb7djk.dxcluster.net Git - spider.git/blob - perl/DXDebug.pm
stop dbg init when not in debug mode.
[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 #       To print the current contents into the debug log: show/debug_ring
12 #
13 #       On exit or serious error the ring buffer is printed to the current debug log
14 #
15 # In Progress:
16 #       Expose a localhost listener on port (default) 27755 to things like watchdbg so that they can carry on
17 #       as normal, possibly with a "remember" button to permanently capture stuff observed.
18 #
19 # Future:
20 #       This is likely to be some form of triggering or filtering controlling (some portion
21 #       of) ring_buffer dumping.
22 #
23 #
24
25 package DXDebug;
26
27 use 5.10.1;
28
29 require Exporter;
30 @ISA = qw(Exporter);
31 @EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose dbgtrace confess croak cluck carp);
32
33 use strict;
34 use vars qw(%dbglevel $fp $callback $cleandays $keepdays $dbgringlth);
35
36 use DXUtil;
37 use DXLog ();
38 use Carp ();
39 use POSIX qw(isatty);
40
41 %dbglevel = ();
42 $fp = undef;
43 $callback = undef;
44 $keepdays = 10;
45 $cleandays = 100;
46 $dbgringlth = 500;
47
48 our $no_stdout;                                 # set if not running in a terminal
49 our @dbgring;
50
51 # Avoid generating "subroutine redefined" warnings with the following
52 # hack (from CGI::Carp):
53 if (!defined $DB::VERSION) {
54         local $^W=0;
55         eval qq( sub confess { 
56             \$SIG{__DIE__} = 'DEFAULT'; 
57         DXDebug::dbgprintring() if DXDebug::isdbg('nologchan');
58         DXDebug::dbg(\$@);
59 #               DXDebug::dbg(Carp::shortmess(\@_));
60         DXDebug::longmess(\@_);
61             exit(-1); 
62         }
63         sub croak { 
64                 \$SIG{__DIE__} = 'DEFAULT'; 
65         DXDebug::dbgprintring() if DXDebug::isdbg('nologchan');
66         DXDebug::dbg(\$@);
67 #               DXDebug::dbg(Carp::longmess(\@_));
68         DXDebug::shortmess(\@_);
69                 exit(-1); 
70         }
71         sub carp { 
72         DXDebug::dbgprintring(25) if DXDebug('nologchan');
73 #        DXDebug::dbg(Carp::shortmess(\@_)); 
74         DXDebug::longmess(\@_);
75     }
76         sub cluck { 
77         DXDebug::dbgprintring(25) if DXDebug('nologchan');
78 #        DXDebug::dbg(Carp::longmess(\@_)); 
79         DXDebug::longmess(\@_);
80     } );
81
82     CORE::die(Carp::shortmess($@)) if $@;
83 } else {
84     eval qq( sub confess { die Carp::longmess(\@_); }; 
85                          sub croak { die Carp::shortmess(\@_); }; 
86                          sub cluck { warn Carp::longmess(\@_); }; 
87                          sub carp { warn Carp::shortmess(\@_); }; 
88    );
89
90
91
92 my $_isdbg = '';                                                # current dbg level we are processing
93
94 # print stack trace
95 sub dbgtrace
96 {
97 #       say "*** in dbgtrace";
98         $_isdbg = 'trace';
99         dbg(@_);
100         for (my $i = 1; (my ($pkg, $fn, $l, $subr) = caller($i)); ++$i) {
101 #               say "*** in dbgtrace $i";
102                 next if $pkg eq 'DXDebug';
103 #               say "*** in dbgtrace after package";
104                 last if $pkg =~ /Mojo/;
105 #               say "*** in dbgtrace $i after mojo";
106                 $_isdbg = 'trace';
107                 dbg("Stack ($i): $pkg::$subr in $fn line: $l");
108         }
109         $_isdbg = '';
110 }
111
112 sub dbg
113 {
114 #       return unless $fp;
115         my $t = time; 
116         for (@_) {
117                 my $r = $_;
118                 chomp $r;
119                 my @l = split /\n/, $r;
120                 foreach my $l (@l) {
121                         $l =~ s/([\x00-\x08\x0B-\x1f\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
122                         my $tag = $_isdbg ? "($_isdbg) " : '(*) ';
123                         print "$tag$l\n" if defined \*STDOUT && !$no_stdout;
124                         my $str = "$t^$tag$l";
125                         &$callback($str) if $callback;
126                         if ($dbgringlth) {
127                                 shift @dbgring while (@dbgring > $dbgringlth);
128                                 push @dbgring, $str;
129                         }
130                         $fp->writeunix($t, $str) unless !$fp || $dbglevel{"nolog$_isdbg"} ; 
131                 }
132         }
133         $_isdbg = '';
134 }
135
136 sub dbginit
137 {
138         $callback = shift;
139         
140         # add sig{__DIE__} handling
141         unless (defined $DB::VERSION) {
142                 $SIG{__WARN__} = sub { 
143                         if ($_[0] =~ /Deep\s+recursion/i) {
144                                 dbg($@);
145                                 dbg(Carp::longmess(@_)); 
146                                 CORE::die;
147                         }
148                         else { 
149                                 dbg($@);
150                                 dbg(Carp::shortmess(@_));
151                         }
152                 };
153                 
154                 $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); };
155
156                 # switch off STDOUT printing if we are not talking to a TTY
157                 unless ($^O =~ /^MS/ || $^O =~ /^OS-2/) {
158                         unless (isatty(STDOUT->fileno)) {
159                                 ++$no_stdout;
160                         }
161                 }
162         }
163
164         $fp = DXLog::new('debug', 'dat', 'd');
165         dbgclearring();
166 }
167
168 sub dbgclose
169 {
170         $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT';
171         if ($fp) {
172                 dbgprintring() if grep /nolog/, keys %dbglevel;
173                 $fp->close();
174         }
175         dbgclearring();
176         undef $fp;
177 }
178
179 sub dbgdump
180 {
181         return unless $fp;
182         
183         my $l = shift;
184         my $m = shift;
185         if ($dbglevel{$l} || $l eq 'err') {
186                 my @out;
187                 foreach my $l (@_) {
188                         for (my $o = 0; $o < length $l; $o += 16) {
189                                 my $c = substr $l, $o, 16;
190                                 my $h = unpack "H*", $c;
191                                 $c =~ s/[\x00-\x1f\x7f-\xff]/./g;
192                                 my $left = 16 - length $c;
193                                 $h .= ' ' x (2 * $left) if $left > 0;
194                                 push @out, $m . sprintf("%4d:", $o) . "$h $c";
195                                 $m = ' ' x (length $m);
196                         }
197                 }
198                 dbg(@out) if isdbg($l); # yes, I know, I have my reasons;
199         } 
200 }
201
202 sub dbgadd
203
204         my $entry;
205         
206         foreach $entry (@_) {
207                 $dbglevel{$entry} = 1;
208         }
209 }
210
211 sub dbgsub
212 {
213         my $entry;
214         
215         foreach $entry (@_) {
216                 delete $dbglevel{$entry};
217         }
218 }
219
220 sub dbglist
221 {
222         return keys (%dbglevel);
223 }
224
225 sub isdbg($)
226 {
227         return unless $fp;
228         if ($dbglevel{$_[0]}) {
229                 $_isdbg = $_[0];
230                 return 1;
231     }
232 }
233
234 sub shortmess 
235 {
236         return dbgtrace(@_);
237 }
238
239 sub longmess 
240 {
241         return dbgtrace(@_);
242 }
243
244 sub dbgprintring
245 {
246         return unless $fp;
247         my $i = shift || 0;
248         my $count = @dbgring;
249         $i =  @dbgring-$i if $i;
250         return 0 unless $i < $count;    # do nothing if there is nothing to print
251
252         my $first;
253         my $l;
254         for ( ; $i < $count; ++$i) {
255                 my ($t, $str) = split /\^/, $dbgring[$i], 2;
256                 next unless $t;
257                 my $lt = time;
258                 unless ($first) {
259                         $fp->writeunix($lt, "$lt^###");
260                         $fp->writeunix($lt, "$lt^### RINGBUFFER START at line $i (zero base)");
261                         $fp->writeunix($lt, "$lt^###");
262                         $first = $t;
263                 }
264                 my $buf = sprintf "%02d:%02d:%02d", (gmtime($t))[2,1,0];
265                 $fp->writeunix($lt, "$lt^RING: $buf^$str");
266                 ++$l;
267         }
268         my $et = time;
269         $fp->writeunix($et, "$et^###");
270         $fp->writeunix($et, "$et^### RINGBUFFER END $l debug lines written");
271         $fp->writeunix($et, "$et^###");
272         return $l;
273 }
274
275 sub dbgclearring
276 {
277         @dbgring = ();
278 }
279
280 # clean out old debug files, stop when you get a gap of more than a month
281 sub dbgclean
282 {
283         my $date = $fp->unixtoj($main::systime)->sub($keepdays+1);
284         my $i = 0;
285
286         while ($i < 31) {
287                 my $fn = $fp->_genfn($date);
288                 if (-e $fn) {
289                         unlink $fn;
290                         $i = 0;
291                 }
292                 else {
293                         $i++;
294                 }
295                 $date = $date->sub(1);
296         }
297 }
298
299 1;
300 __END__
301
302
303
304
305
306
307