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