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