X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXDebug.pm;h=57a8237a45d48561349f45ebba5c30e9d3efb7f6;hb=9c8f43f26a7db08c4ff6ef2213c95c9f509abe36;hp=08703d7c8230e49b780d71821d60cbd65719a1d4;hpb=83445c4f6ec6c885260944a9abe648aced399c40;p=spider.git diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm index 08703d7c..57a8237a 100644 --- a/perl/DXDebug.pm +++ b/perl/DXDebug.pm @@ -8,12 +8,27 @@ # To allow debugging of a category (e.g. 'chan') but not onto disc (just into the ring buffer) # do: set/debug chan nologchan # +# To print the current contents into the debug log: show/debug_ring +# +# On exit or serious error the ring buffer is printed to the current debug log +# +# In Progress: +# Expose a localhost listener on port (default) 27755 to things like watchdbg so that they can carry on +# as normal, possibly with a "remember" button to permanently capture stuff observed. +# +# Future: +# This is likely to be some form of triggering or filtering controlling (some portion +# of) ring_buffer dumping. +# +# package DXDebug; +use 5.10.1; + require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck); +@EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose dbgtrace dbgprintring confess croak cluck carp); use strict; use vars qw(%dbglevel $fp $callback $cleandays $keepdays $dbgringlth); @@ -39,27 +54,33 @@ if (!defined $DB::VERSION) { local $^W=0; eval qq( sub confess { \$SIG{__DIE__} = 'DEFAULT'; - DXDebug::dbgprintring() unless DXDebug::isdbg('chan'); - DXDebug::dbgclearring(); + DXDebug::dbgprintring() if DXDebug::isdbg('nologchan'); DXDebug::dbg(\$@); - DXDebug::dbg(Carp::shortmess(\@_)); +# DXDebug::dbg(Carp::shortmess(\@_)); + DXDebug::longmess(\@_); exit(-1); } sub croak { \$SIG{__DIE__} = 'DEFAULT'; - DXDebug::dbgprintring() unless DXDebug::isdbg('chan'); - DXDebug::dbgclearring(); + DXDebug::dbgprintring() if DXDebug::isdbg('nologchan'); DXDebug::dbg(\$@); - DXDebug::dbg(Carp::longmess(\@_)); +# DXDebug::dbg(Carp::longmess(\@_)); + DXDebug::shortmess(\@_); exit(-1); } - sub carp { DXDebug::dbg(Carp::shortmess(\@_)); } - sub cluck { DXDebug::dbg(Carp::longmess(\@_)); } - ); + sub carp { + DXDebug::dbgprintring(25) if DXDebug('nologchan'); +# DXDebug::dbg(Carp::shortmess(\@_)); + DXDebug::longmess(\@_); + } + sub cluck { + DXDebug::dbgprintring(25) if DXDebug('nologchan'); +# DXDebug::dbg(Carp::longmess(\@_)); + DXDebug::longmess(\@_); + } ); CORE::die(Carp::shortmess($@)) if $@; -} -else { +} else { eval qq( sub confess { die Carp::longmess(\@_); }; sub croak { die Carp::shortmess(\@_); }; sub cluck { warn Carp::longmess(\@_); }; @@ -68,26 +89,45 @@ else { } -my $_isdbg; # current dbg level we are processing +my $_isdbg = ''; # current dbg level we are processing -sub dbg($) +# print stack trace +sub dbgtrace { - return unless $fp; +# say "*** in dbgtrace"; + $_isdbg = 'trace'; + dbg(@_); + for (my $i = 1; (my ($pkg, $fn, $l, $subr) = caller($i)); ++$i) { +# say "*** in dbgtrace $i"; + next if $pkg eq 'DXDebug'; +# say "*** in dbgtrace after package"; + last if $pkg =~ /Mojo/; +# say "*** in dbgtrace $i after mojo"; + $_isdbg = 'trace'; + dbg("Stack ($i): $pkg::$subr in $fn line: $l"); + } + $_isdbg = ''; +} + +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 && !$no_stdout; - my $str = "$t^$_"; + foreach my $l (@l) { + $l =~ s/([\x00-\x08\x0B-\x1f\x7f-\xff])/sprintf("%%%02X",ord($1))/eg; + my $tag = $_isdbg ? "($_isdbg) " : '(*) '; + print "$tag$l\n" if defined \*STDOUT && !$no_stdout; + my $str = "$t^$tag$l"; &$callback($str) if $callback; if ($dbgringlth) { shift @dbgring while (@dbgring > $dbgringlth); push @dbgring, $str; } - $fp->writeunix($t, $str) unless $dbglevel{"nolog$_isdbg"}; + $fp->writeunix($t, $str) unless !$fp || $dbglevel{"nolog$_isdbg"} ; } } $_isdbg = ''; @@ -95,6 +135,7 @@ sub dbg($) sub dbginit { + my $basename = shift || 'debug'; $callback = shift; # add sig{__DIE__} handling @@ -121,7 +162,7 @@ sub dbginit } } - $fp = DXLog::new('debug', 'dat', 'd'); + $fp = DXLog::new($basename, 'dat', 'd'); dbgclearring(); } @@ -143,6 +184,7 @@ sub dbgdump my $l = shift; my $m = shift; if ($dbglevel{$l} || $l eq 'err') { + my @out; foreach my $l (@_) { for (my $o = 0; $o < length $l; $o += 16) { my $c = substr $l, $o, 16; @@ -150,11 +192,12 @@ sub dbgdump $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"); + push @out, $m . sprintf("%4d:", $o) . "$h $c"; $m = ' ' x (length $m); } } - } + dbg(@out) if isdbg($l); # yes, I know, I have my reasons; + } } sub dbgadd @@ -191,35 +234,43 @@ sub isdbg($) sub shortmess { - return Carp::shortmess(@_); + return dbgtrace(@_); } sub longmess { - return Carp::longmess(@_); + return dbgtrace(@_); } sub dbgprintring { return unless $fp; + my $i = shift || 0; + my $count = @dbgring; + $i = @dbgring-$i if $i; + return 0 unless $i < $count; # do nothing if there is nothing to print + my $first; - while (my $l = shift @dbgring) { - my ($t, $str) = split /\^/, $l, 2; + my $l; + for ( ; $i < $count; ++$i) { + my ($t, $str) = split /\^/, $dbgring[$i], 2; next unless $t; my $lt = time; unless ($first) { $fp->writeunix($lt, "$lt^###"); - $fp->writeunix($lt, "$lt^### RINGBUFFER START"); + $fp->writeunix($lt, "$lt^### RINGBUFFER START at line $i (zero base)"); $fp->writeunix($lt, "$lt^###"); $first = $t; } my $buf = sprintf "%02d:%02d:%02d", (gmtime($t))[2,1,0]; $fp->writeunix($lt, "$lt^RING: $buf^$str"); + ++$l; } my $et = time; $fp->writeunix($et, "$et^###"); - $fp->writeunix($et, "$et^### RINGBUFFER END"); + $fp->writeunix($et, "$et^### RINGBUFFER END $l debug lines written"); $fp->writeunix($et, "$et^###"); + return $l; } sub dbgclearring