]> scm.dxcluster.org Git - spider.git/blob - perl/DXDebug.pm
*** empty log message ***
[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 isdbg dbgclose confess croak cluck cluck);
15
16 use strict;
17 use vars qw(%dbglevel $fp);
18
19 use DXUtil;
20 use DXLog ();
21 use Carp;
22
23 %dbglevel = ();
24 $fp = DXLog::new('debug', 'dat', 'd');
25
26 # Avoid generating "subroutine redefined" warnings with the following
27 # hack (from CGI::Carp):
28 if (!defined $DB::VERSION) {
29         local $^W=0;
30         eval qq( sub confess { 
31            \$SIG{__DIE__} = 'DEFAULT'; 
32            DXDebug::_store(Carp::longmess(\@_)); 
33            exit(-1); 
34         }
35         sub confess { 
36                 \$SIG{__DIE__} = 'DEFAULT'; 
37                 DXDebug::_store(Carp::shortmess(\@_)); 
38                 exit(-1); 
39         }
40         sub carp    { DXDebug::_store(Carp::shortmess(\@_)); }
41         sub cluck   { DXDebug::_store(Carp::longmess(\@_)); } 
42         );
43
44     CORE::die(Carp::shortmess($@)) if $@;
45 }
46
47
48 sub _store
49 {
50         my $t = time; 
51         for (@_) {
52                 $fp->writeunix($t, "$t^$_"); 
53                 print STDERR $_;
54         }
55 }
56
57 sub dbginit
58 {
59         # add sig{__DIE__} handling
60         if (!defined $DB::VERSION) {
61                 $SIG{__WARN__} = sub { _store(Carp::shortmess(@_)); };
62                 $SIG{__DIE__} = sub { _store(Carp::shortmess(@_)); };
63         }
64 }
65
66 sub dbgclose
67 {
68         $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT';
69         $fp->close();
70 }
71
72 sub dbg
73 {
74         my $l = shift;
75         if ($dbglevel{$l} || $l eq 'err') {
76             my @in = @_;
77                 my $t = time;
78                 for (@in) {
79                     s/\n$//o;
80                         s/\a//og;   # beeps
81                         print "$_\n" if defined \*STDOUT;
82                         $fp->writeunix($t, "$t^$_");
83                 }
84         }
85 }
86
87 sub dbgadd
88
89         my $entry;
90         
91         foreach $entry (@_) {
92                 $dbglevel{$entry} = 1;
93         }
94 }
95
96 sub dbgsub
97 {
98         my $entry;
99         
100         foreach $entry (@_) {
101                 delete $dbglevel{$entry};
102         }
103 }
104
105 sub dbglist
106 {
107         return keys (%dbglevel);
108 }
109
110 sub isdbg
111 {
112         my $s = shift;
113         return $dbglevel{$s};
114 }
115
116 sub shortmess 
117 {
118         return Carp::shortmess(@_);
119 }
120
121 sub longmess 
122
123         return Carp::longmess(@_);
124 }
125
126 1;
127 __END__
128
129
130
131
132
133
134