]> www.dxcluster.org Git - spider.git/blob - perl/DXDebug.pm
add CTY-2615 prefixes
[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 - Dirk Koopman G1TLH
6 #
7 #
8 #
9
10 package DXDebug;
11
12 require Exporter;
13 @ISA = qw(Exporter);
14 @EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck);
15
16 use strict;
17 use vars qw(%dbglevel $fp $callback $cleandays $keepdays);
18
19 use DXUtil;
20 use DXLog ();
21 use Carp ();
22 use POSIX qw(isatty);
23
24 %dbglevel = ();
25 $fp = undef;
26 $callback = undef;
27 $keepdays = 10;
28 $cleandays = 100;
29
30 our $no_stdout;                                 # set if not running in a terminal
31
32 # Avoid generating "subroutine redefined" warnings with the following
33 # hack (from CGI::Carp):
34 if (!defined $DB::VERSION) {
35         local $^W=0;
36         eval qq( sub confess { 
37             \$SIG{__DIE__} = 'DEFAULT'; 
38         DXDebug::dbg(\$@);
39                 DXDebug::dbg(Carp::shortmess(\@_));
40             exit(-1); 
41         }
42         sub croak { 
43                 \$SIG{__DIE__} = 'DEFAULT'; 
44         DXDebug::dbg(\$@);
45                 DXDebug::dbg(Carp::longmess(\@_));
46                 exit(-1); 
47         }
48         sub carp    { DXDebug::dbg(Carp::shortmess(\@_)); }
49         sub cluck   { DXDebug::dbg(Carp::longmess(\@_)); } 
50         );
51
52     CORE::die(Carp::shortmess($@)) if $@;
53 } else {
54     eval qq( sub confess { die Carp::longmess(\@_); }; 
55                          sub croak { die Carp::shortmess(\@_); }; 
56                          sub cluck { warn Carp::longmess(\@_); }; 
57                          sub carp { warn Carp::shortmess(\@_); }; 
58    );
59
60
61
62 sub dbg($)
63 {
64         return unless $fp;
65         my $t = time; 
66         for (@_) {
67                 my $r = $_;
68                 chomp $r;
69                 my @l = split /\n/, $r;
70                 for (@l) {
71                         s/([\x00-\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
72                         print "$_\n" if defined \*STDOUT && !$no_stdout;
73                         my $str = "$t^$_";
74                         &$callback($str) if $callback;
75                         $fp->writeunix($t, $str); 
76                 }
77         }
78 }
79
80 sub dbginit
81 {
82         $callback = shift;
83         
84         # add sig{__DIE__} handling
85         unless (defined $DB::VERSION) {
86                 $SIG{__WARN__} = sub { 
87                         if ($_[0] =~ /Deep\s+recursion/i) {
88                                 dbg($@);
89                                 dbg(Carp::longmess(@_)); 
90                                 CORE::die;
91                         } else { 
92                                 dbg($@);
93                                 dbg(Carp::shortmess(@_));
94                         }
95                 };
96                 
97                 $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); };
98
99                 # switch off STDOUT printing if we are not talking to a TTY
100                 unless ($^O =~ /^MS/ || $^O =~ /^OS-2/) {
101                         unless (isatty(STDOUT->fileno)) {
102                                 ++$no_stdout;
103                         }
104                 }
105         }
106
107         $fp = DXLog::new('debug', 'dat', 'd');
108 }
109
110 sub dbgclose
111 {
112         $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT';
113         $fp->close() if $fp;
114         undef $fp;
115 }
116
117 sub dbgdump
118 {
119         return unless $fp;
120         
121         my $l = shift;
122         my $m = shift;
123         if ($dbglevel{$l} || $l eq 'err') {
124                 foreach my $l (@_) {
125                         for (my $o = 0; $o < length $l; $o += 16) {
126                                 my $c = substr $l, $o, 16;
127                                 my $h = unpack "H*", $c;
128                                 $c =~ s/[\x00-\x1f\x7f-\xff]/./g;
129                                 my $left = 16 - length $c;
130                                 $h .= ' ' x (2 * $left) if $left > 0;
131                                 dbg($m . sprintf("%4d:", $o) . "$h $c");
132                                 $m = ' ' x (length $m);
133                         }
134                 }
135         }
136 }
137
138 sub dbgadd
139
140         my $entry;
141         
142         foreach $entry (@_) {
143                 $dbglevel{$entry} = 1;
144         }
145 }
146
147 sub dbgsub
148 {
149         my $entry;
150         
151         foreach $entry (@_) {
152                 delete $dbglevel{$entry};
153         }
154 }
155
156 sub dbglist
157 {
158         return keys (%dbglevel);
159 }
160
161 sub isdbg($)
162 {
163         return unless $fp;
164         return $dbglevel{$_[0]};
165 }
166
167 sub shortmess 
168 {
169         return Carp::shortmess(@_);
170 }
171
172 sub longmess 
173
174         return Carp::longmess(@_);
175 }
176
177 # clean out old debug files, stop when you get a gap of more than a month
178 sub dbgclean
179 {
180         my $date = $fp->unixtoj($main::systime)->sub($keepdays+1);
181         my $i = 0;
182
183         while ($i < 31) {
184                 my $fn = $fp->_genfn($date);
185                 if (-e $fn) {
186                         unlink $fn;
187                         $i = 0;
188                 } else {
189                         $i++;
190                 }
191                 $date = $date->sub(1);
192         }
193 }
194
195 1;
196 __END__
197
198
199
200
201
202
203