use #!/usr/bin/env rather than /bin/env

[spider.git] / perl / DXDebug.pm

diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm
index 14f8dbd2a06ad753c559d3ed9c2cb56a52d8045b..1207492dbb0ec77209edb8816b4d574b95f8177a 100644 (file)
--- a/perl/DXDebug.pm
+++ b/perl/DXDebug.pm
@@ -4,7 +4,7 @@
 #
 # Copyright (c) 1998 - Dirk Koopman G1TLH
 #
-# $Id$
+#
 #
 
 package DXDebug;
@@ -14,15 +14,20 @@ require Exporter;
 @EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck);
 
 use strict;
-use vars qw(%dbglevel $fp $callback);
+use vars qw(%dbglevel $fp $callback $cleandays $keepdays);
 
 use DXUtil;
 use DXLog ();
 use Carp ();
+use POSIX qw(isatty);
 
 %dbglevel = ();
 $fp = undef;
 $callback = undef;
+$keepdays = 10;
+$cleandays = 100;
+
+our $no_stdout;                                        # set if not running in a terminal
 
 # Avoid generating "subroutine redefined" warnings with the following
 # hack (from CGI::Carp):
@@ -64,7 +69,7 @@ sub dbg($)
                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;
+                       print "$_\n" if defined \*STDOUT && !$no_stdout;
                        my $str = "$t^$_";
                        &$callback($str) if $callback;
                        $fp->writeunix($t, $str); 
@@ -77,7 +82,7 @@ sub dbginit
        $callback = shift;
        
        # add sig{__DIE__} handling
-       if (!defined $DB::VERSION) {
+       unless (defined $DB::VERSION) {
                $SIG{__WARN__} = sub { 
                        if ($_[0] =~ /Deep\s+recursion/i) {
                                dbg($@);
@@ -90,6 +95,13 @@ sub dbginit
                };
                
                $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); };
+
+               # switch off STDOUT printing if we are not talking to a TTY
+               unless ($^O =~ /^MS/ || $^O =~ /^OS-2/) {
+                       unless (isatty(STDOUT->fileno)) {
+                               ++$no_stdout;
+                       }
+               }
        }
 
        $fp = DXLog::new('debug', 'dat', 'd');
@@ -104,9 +116,11 @@ sub dbgclose
 
 sub dbgdump
 {
+       return unless $fp;
+       
        my $l = shift;
        my $m = shift;
-       if ($fp && ($dbglevel{$l} || $l eq 'err')) {
+       if ($dbglevel{$l} || $l eq 'err') {
                foreach my $l (@_) {
                        for (my $o = 0; $o < length $l; $o += 16) {
                                my $c = substr $l, $o, 16;
@@ -160,6 +174,24 @@ 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__