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 dbgsetcat confess croak cluck carp);
use strict;
use vars qw(%dbglevel $fp $callback $cleandays $keepdays $dbgringlth);
\$SIG{__DIE__} = 'DEFAULT';
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() if DXDebug::isdbg('nologchan');
DXDebug::dbg(\$@);
- DXDebug::dbg(Carp::longmess(\@_));
+# DXDebug::dbg(Carp::longmess(\@_));
+ DXDebug::shortmess(\@_);
exit(-1);
}
sub carp {
- DXDebug::dbgprintring(25) if DXDebug('nologchan');
- DXDebug::dbg(Carp::shortmess(\@_));
+ DXDebug::dbgprintring(5) if DXDebug::isdbg('nologchan');
+# DXDebug::dbg(Carp::shortmess(\@_));
+ DXDebug::longmess(\@_);
}
sub cluck {
- DXDebug::dbgprintring(25) if DXDebug('nologchan');
- DXDebug::dbg(Carp::longmess(\@_));
+ DXDebug::dbgprintring(5) if DXDebug::isdbg('nologchan');
+# DXDebug::dbg(Carp::longmess(\@_));
+ DXDebug::longmess(\@_);
} );
CORE::die(Carp::shortmess($@)) if $@;
}
-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 = '';
sub dbginit
{
+ my $basename = shift || 'debug';
$callback = shift;
# add sig{__DIE__} handling
}
}
- $fp = DXLog::new('debug', 'dat', 'd');
+ $fp = DXLog::new($basename, 'dat', 'd');
dbgclearring();
}
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;
$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
sub shortmess
{
- return Carp::shortmess(@_);
+ return dbgtrace(@_);
}
sub longmess
{
- return Carp::longmess(@_);
+ return dbgtrace(@_);
}
sub dbgprintring
{
return unless $fp;
- my $count = shift;
+ 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;
my $l;
- my $i = defined $count ? @dbgring-$count : 0;
- $count = @dbgring;
for ( ; $i < $count; ++$i) {
my ($t, $str) = split /\^/, $dbgring[$i], 2;
next unless $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
}
}
+# force a category for the next (unconditional) dbg message (replace (*) with (<something>))
+sub dbgsetcat
+{
+ $_isdbg = shift;
+}
+
1;
__END__