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