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);
  15 @EXPORT_OK = qw(dbginit dbg dbgadd dbgsub dbglist isdbg dbgclose);
  16
  17 use strict;
  18 use vars qw(%dbglevel $fp);
  19
  20 use FileHandle;
  21 use DXUtil;
  22 use DXLog ();
  23 use Carp;
  24
  25 %dbglevel = ();
  26 $fp = DXLog::new('debug', 'dat', 'd');
  27
  28 sub _store
  29 {
  30         my $t = time;
  31         for (@_) {
  32                 $fp->writeunix($t, "$t^$_");
  33                 print STDERR $_;
  34         }
  35 }
  36
  37 sub dbginit
  38 {
  39         # add sig{__DIE__} handling
  40         if (!defined $DB::VERSION) {
  41                 $SIG{__WARN__} = $SIG{__DIE__} = \&_store;
  42         }
  43 }
  44
  45 sub dbgclose
  46 {
  47         $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT';
  48         $fp->close();
  49 }
  50
  51 sub dbg
  52 {
  53         my $l = shift;
  54         if ($dbglevel{$l}) {
  55             my @in = @_;
  56                 my $t = time;
  57                 for (@in) {
  58                     s/\n$//o;
  59                         s/\a//og;   # beeps
  60                         print "$_\n" if defined \*STDOUT;
  61                         $fp->writeunix($t, "$t^$_");
  62                 }
  63         }
  64 }
  65
  66 sub dbgadd
  67 {
  68         my $entry;
  69
  70         foreach $entry (@_) {
  71                 $dbglevel{$entry} = 1;
  72         }
  73 }
  74
  75 sub dbgsub
  76 {
  77         my $entry;
  78
  79         foreach $entry (@_) {
  80                 delete $dbglevel{$entry};
  81         }
  82 }
  83
  84 sub dbglist
  85 {
  86         return keys (%dbglevel);
  87 }
  88
  89 sub isdbg
  90 {
  91         my $s = shift;
  92         return $dbglevel{$s};
  93 }
  94 1;
  95 __END__