X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXDebug.pm;h=821c41b44ea40791ccea40620adb642367a4d529;hb=2b58ccdf81685a1167a43c38705a0d84b9d8d661;hp=96cc0ec256e6c9429071946518a01eee8c5de552;hpb=a9b7071fedfdb2150f3ef3d74e0d626b4f2dc0ea;p=spider.git diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm index 96cc0ec2..821c41b4 100644 --- a/perl/DXDebug.pm +++ b/perl/DXDebug.pm @@ -11,33 +11,121 @@ package DXDebug; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(dbg dbgadd dbgsub dbglist isdbg); -@EXPORT_OK = qw(dbg dbgadd dbgsub dbglist isdbg); +@EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck); use strict; -use vars qw(%dbglevel $fp); +use vars qw(%dbglevel $fp $callback $cleandays $keepdays); -use FileHandle; use DXUtil; use DXLog (); -use Carp; +use Carp (); %dbglevel = (); -$fp = DXLog::new('debug', 'dat', 'd'); +$fp = undef; +$callback = undef; +$keepdays = 10; +$cleandays = 100; -no strict 'refs'; +use vars qw($VERSION $BRANCH); +$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); +$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0; +$main::build += $VERSION; +$main::branch += $BRANCH; -sub dbg +# Avoid generating "subroutine redefined" warnings with the following +# hack (from CGI::Carp): +if (!defined $DB::VERSION) { + local $^W=0; + eval qq( sub confess { + \$SIG{__DIE__} = 'DEFAULT'; + DXDebug::dbg(\$@); + DXDebug::dbg(Carp::shortmess(\@_)); + exit(-1); + } + sub croak { + \$SIG{__DIE__} = 'DEFAULT'; + DXDebug::dbg(\$@); + DXDebug::dbg(Carp::longmess(\@_)); + exit(-1); + } + sub carp { DXDebug::dbg(Carp::shortmess(\@_)); } + sub cluck { DXDebug::dbg(Carp::longmess(\@_)); } + ); + + CORE::die(Carp::shortmess($@)) if $@; +} else { + eval qq( sub confess { die Carp::longmess(\@_); }; + sub croak { die Carp::shortmess(\@_); }; + sub cluck { warn Carp::longmess(\@_); }; + sub carp { warn Carp::shortmess(\@_); }; + ); +} + + +sub dbg($) +{ + return unless $fp; + my $t = time; + for (@_) { + my $r = $_; + chomp $r; + my @l = split /\n/, $r; + for (@l) { + s/([\x00-\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg; + print "$_\n" if defined \*STDOUT; + my $str = "$t^$_"; + &$callback($str) if $callback; + $fp->writeunix($t, $str); + } + } +} + +sub dbginit +{ + $callback = shift; + + # add sig{__DIE__} handling + if (!defined $DB::VERSION) { + $SIG{__WARN__} = sub { + if ($_[0] =~ /Deep\s+recursion/i) { + dbg($@); + dbg(Carp::longmess(@_)); + CORE::die; + } else { + dbg($@); + dbg(Carp::shortmess(@_)); + } + }; + + $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); }; + } + + $fp = DXLog::new('debug', 'dat', 'd'); +} + +sub dbgclose +{ + $SIG{__DIE__} = $SIG{__WARN__} = 'DEFAULT'; + $fp->close() if $fp; + undef $fp; +} + +sub dbgdump { my $l = shift; - if ($dbglevel{$l}) { - for (@_) { - s/\n$//og; - s/\a//og; # beeps + my $m = shift; + if ($fp && ($dbglevel{$l} || $l eq 'err')) { + foreach my $l (@_) { + for (my $o = 0; $o < length $l; $o += 16) { + my $c = substr $l, $o, 16; + my $h = unpack "H*", $c; + $c =~ s/[\x00-\x1f\x7f-\xff]/./g; + my $left = 16 - length $c; + $h .= ' ' x (2 * $left) if $left > 0; + dbg($m . sprintf("%4d:", $o) . "$h $c"); + $m = ' ' x (length $m); + } } - print "@_\n" if defined \*STDOUT; - my $t = time; - $fp->writeunix($t, "$t^@_"); } } @@ -55,7 +143,7 @@ sub dbgsub my $entry; foreach $entry (@_) { - delete $dbglevel{entry}; + delete $dbglevel{$entry}; } } @@ -64,9 +152,46 @@ sub dbglist return keys (%dbglevel); } -sub isdbg +sub isdbg($) { - return $dbglevel{shift}; + return unless $fp; + return $dbglevel{$_[0]}; } + +sub shortmess +{ + return Carp::shortmess(@_); +} + +sub longmess +{ + return Carp::longmess(@_); +} + +# clean out old debug files, stop when you get a gap of more than a month +sub dbgclean +{ + my $date = $fp->unixtoj($main::systime)->sub($keepdays+1); + my $i = 0; + + while ($i < 31) { + my $fn = $fp->_genfn($date); + if (-e $fn) { + unlink $fn; + $i = 0; + } else { + $i++; + } + $date = $date->sub(1); + } +} + 1; __END__ + + + + + + +