Debug.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 # This library is free software; you can redistribute it and/or
   8 # modify it under the same terms as Perl itself.
   9 #
  10
  11 package Debug;
  12
  13 require Exporter;
  14
  15 @ISA = qw(Exporter);
  16 @EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck carp);
  17 $VERSION = 1.23;
  18
  19 use strict;
  20 use vars qw(%dbglevel $fp);
  21 use 5.01001;
  22
  23 use SMGLog ();
  24 use Carp qw(cluck);
  25 use Time::HiRes qw(gettimeofday);
  26
  27 %dbglevel = ();
  28 $fp = undef;
  29
  30 # Avoid generating "subroutine redefined" warnings with the following
  31 # hack (from CGI::Carp):
  32 if (!defined $DB::VERSION) {
  33         local $^W=0;
  34         eval qq( sub confess {
  35             \$SIG{__DIE__} = 'DEFAULT';
  36         Debug::dbg(\$@, Carp::shortmess(\@_));
  37             exit(-1);
  38         }
  39         sub croak {
  40                 \$SIG{__DIE__} = 'DEFAULT';
  41         Debug::dbg(\$@, Carp::longmess(\@_));
  42                 exit(-1);
  43         }
  44         sub carp    { Debug::dbg(Carp::shortmess(\@_)); }
  45         sub cluck   { Debug::dbg(Carp::longmess(\@_)); }
  46         );
  47
  48     CORE::die(Carp::shortmess($@)) if $@;
  49 } else {
  50     eval qq( sub confess { Carp::confess(\@_); }
  51         sub cluck { Carp::cluck(\@_); }
  52         sub carp { Carp::cluck(\@_); }
  53    );
  54 }
  55
  56 dbginit();
  57
  58 sub dbg
  59 {
  60         my ($t,$ut) = gettimeofday;
  61         my $ts = sprintf "%02d:%02d:%02d:%03d", (gmtime($t))[2,1,0], $ut/1000;
  62         for (@_) {
  63                 my $r = $_;
  64                 chomp $r;
  65                 my @l = split /\n/, $r;
  66                 for (@l) {
  67                         s/([\x00-\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
  68 #                       print "$_\n" if defined \*STDOUT;
  69                         $fp->writeunix($t, "$ts $_");
  70                 }
  71         }
  72 }
  73
  74 sub dbginit
  75 {
  76         # add sig{__DIE__} handling
  77         if (!defined $DB::VERSION) {
  78                 $SIG{__WARN__} = sub { dbg($@, Carp::shortmess(@_)); };
  79                 $SIG{__DIE__} = sub { dbg($@, Carp::longmess(@_)); };
  80         }
  81
  82         $fp = SMGLog->new('debug', 'log', 'd');
  83 }
  84
  85 sub dbgclose
  86 {
  87         $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT';
  88         $fp->close() if $fp;
  89         undef $fp;
  90 }
  91
  92 sub dbgdump
  93 {
  94         my $m = shift;
  95
  96         foreach my $l (@_) {
  97                 my $p = $m;
  98                 for (my $o = 0; $o < length $l; $o += 16) {
  99                         my $c = substr $l, $o, 16;
 100                         my $h = unpack "H*", $c;
 101                         $c =~ s/[\x00-\x1f\x7f-\xff]/./g;
 102                         my $left = 16 - length $c;
 103                         $h .= ' ' x (2 * $left) if $left > 0;
 104                         dbg($p . sprintf("%4d:", $o) . "$h $c");
 105                         $p = ' ' x (length $p);
 106                 }
 107         }
 108 }
 109
 110 sub dbgadd
 111 {
 112         my $entry;
 113
 114         foreach $entry (@_) {
 115                 $dbglevel{$entry} = 1;
 116         }
 117 }
 118
 119 sub dbgsub
 120 {
 121         my $entry;
 122
 123         foreach $entry (@_) {
 124                 delete $dbglevel{$entry};
 125         }
 126 }
 127
 128 sub dbglist
 129 {
 130         return keys (%dbglevel);
 131 }
 132
 133 sub isdbg
 134 {
 135         return undef unless $fp;
 136         return $dbglevel{$_[0]};
 137 }
 138
 139 sub shortmess
 140 {
 141         return Carp::shortmess(@_);
 142 }
 143
 144 sub longmess
 145 {
 146         return Carp::longmess(@_);
 147 }
 148
 149 1;
 150 __END__
 151
 152
 153
 154
 155
 156
 157