hamradio/spider
1
0
Fork 0
mirror of git://scm.dxcluster.org/scm/spider synced 2024-09-21 07:47:10 +00:00
Code Issues Packages Projects Releases Wiki Activity

fix grepdbg so it does what grepdbg -h says

Browse Source
This commit is contained in:
Dirk Koopman 2022-01-25 14:42:32 +00:00
parent 48f0cb90d0
commit f653700dec
4 changed files with 204 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Changes
View File

@ -1,3 +1,5 @@
25Jan22=======================================================================
1. Fixed grepdbg so that it does what -help says it does.
21Jan22=======================================================================
1. downgrade console.pl require to perl 5.8.1.
2. Backport grepdbg from mojo.

3
cmd/export_users.pl
View File

@ -8,5 +8,4 @@ my $line = shift || "$main::data/user_asc";
return (1, $self->msg('e5')) unless $self->priv >= 9;
my ($fn, $flag) = split /\s+/, $line;
my $strip = $flag eq 'strip';
return (1, DXUser::export($fn, $strip));
return (1, DXUser::export($fn));

270
perl/DXUser.pm
View File

@ -421,135 +421,6 @@ sub fields
}
#
# export the database to an ascii file
#
sub export
{
my $fn = shift;
my $basic_info_only = shift;
# save old ones
rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
rename "$fn.o", "$fn.oo" if -e "$fn.o";
rename "$fn", "$fn.o" if -e "$fn";
my $count = 0;
my $err = 0;
my $del = 0;
my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
if ($fh) {
my $key = 0;
my $val = undef;
my $action;
my $t = scalar localtime;
print $fh q{#!/usr/bin/perl
#
# The exported userfile for a DXSpider System
#
# Input file: $filename
# Time: $t
#
package main;
# search local then perl directories
BEGIN {
umask 002;
# root of directory tree for this system
$root = "/spider";
$root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
unshift @INC, "$root/perl"; # this IS the right way round!
unshift @INC, "$root/local";
# try to detect a lockfile (this isn't atomic but
# should do for now
$lockfn = "$root/local/cluster.lck"; # lock file name
if (-e $lockfn) {
open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!";
my $pid = <CLLOCK>;
chomp $pid;
die "Lockfile ($lockfn) and process $pid exists - cluster must be stopped first\n" if kill 0, $pid;
close CLLOCK;
}
}
package DXUser;
use DXVars;
use DXUser;
if (@ARGV) {
$main::userfn = shift @ARGV;
print "user filename now $userfn\n";
}
DXUser->del_file($main::userfn);
DXUser->init($main::userfn, 1);
%u = ();
my $count = 0;
my $err = 0;
while (<DATA>) {
chomp;
my @f = split /\t/;
my $ref = asc_decode($f[1]);
if ($ref) {
$ref->put();
$count++;
} else {
print "# Error: $f[0]\t$f[1]\n";
$err++
}
}
DXUser->sync; DXUser->finish;
print "There are $count user records and $err errors\n";
};
print $fh "__DATA__\n";
for ($action = R_FIRST; !$dbm->seq($key, $val, $action); $action = R_NEXT) {
if (!is_callsign($key) || $key =~ /^0/) {
my $eval = $val;
my $ekey = $key;
$eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
$ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
LogDbg('DXCommand', "Export Error1: $ekey\t$eval");
eval {$dbm->del($key)};
dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@;
++$err;
next;
}
my $ref = decode($val);
if ($ref) {
my $t = $ref->{lastin} || 0;
if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
eval {$dbm->del($key)};
dbg(carp("Export Error2: $key\t$val\n$@")) if $@;
LogDbg('DXCommand', "$ref->{call} deleted, too old");
$del++;
next;
}
}
# only store users that are reasonably active or have useful information
print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n";
++$count;
} else {
LogDbg('DXCommand', "Export Error3: $key\t$val");
eval {$dbm->del($key)};
dbg(carp("Export Error3: $key\t$val\n$@")) if $@;
++$err;
}
}
$fh->close;
}
return "$count Users $del Deleted $err Errors ('sh/log Export' for details)";
}
#
# group handling
#
@ -862,6 +733,147 @@ sub lastping
$b->{$call} = shift if @_;
return $b->{$call};
}
#
# export the database to an ascii file
#
sub export
{
my $fn = shift;
my $basic_info_only = shift;
# save old ones
rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
rename "$fn.o", "$fn.oo" if -e "$fn.o";
rename "$fn", "$fn.o" if -e "$fn";
my $count = 0;
my $err = 0;
my $del = 0;
my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
if ($fh) {
my $key = 0;
my $val = undef;
my $action;
my $t = scalar localtime;
print $fh export_preamble();
for ($action = R_FIRST; !$dbm->seq($key, $val, $action); $action = R_NEXT) {
if (!is_callsign($key) || $key =~ /^0/) {
my $eval = $val;
my $ekey = $key;
$eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
$ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
LogDbg('DXCommand', "Export Error1: $ekey\t$eval");
eval {$dbm->del($key)};
dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@;
++$err;
next;
}
my $ref = decode($val);
if ($ref) {
my $t = $ref->{lastin} || 0;
if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
eval {$dbm->del($key)};
dbg(carp("Export Error2: $key\t$val\n$@")) if $@;
LogDbg('DXCommand', "$ref->{call} deleted, too old");
$del++;
next;
}
}
# only store users that are reasonably active or have useful information
print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n";
++$count;
} else {
LogDbg('DXCommand', "Export Error3: $key\t$val");
eval {$dbm->del($key)};
dbg(carp("Export Error3: $key\t$val\n$@")) if $@;
++$err;
}
}
$fh->close;
}
return "$count Users $del Deleted $err Errors ('sh/log Export' for details)";
}
sub export_preamble
{
return q{#!/usr/bin/perl
#
# The exported userfile for a DXSpider System
#
# Input file: $filename
# Time: $t
#
package main;
# search local then perl directories
BEGIN {
umask 002;
# root of directory tree for this system
$root = "/spider";
$root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
unshift @INC, "$root/perl"; # this IS the right way round!
unshift @INC, "$root/local";
# try to detect a lockfile (this isn't atomic but
# should do for now
$lockfn = "$root/local/cluster.lck"; # lock file name
if (-e $lockfn) {
open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!";
my $pid = <CLLOCK>;
chomp $pid;
die "Lockfile ($lockfn) and process $pid exists - cluster must be stopped first\n" if kill 0, $pid;
close CLLOCK;
}
}
package DXUser;
use DXVars;
use DXUser;
if (@ARGV) {
$main::userfn = shift @ARGV;
print "user filename now $userfn\n";
}
DXUser->del_file($main::userfn);
DXUser->init($main::userfn, 1);
%u = ();
my $count = 0;
my $err = 0;
while (<DATA>) {
chomp;
my @f = split /\t/;
my $ref = asc_decode($f[1]);
if ($ref) {
$ref->put();
$count++;
} else {
print "# Error: $f[0]\t$f[1]\n";
$err++
}
}
DXUser->sync; DXUser->finish;
print "There are $count user records and $err errors\n";
exit $err ? -1 : 1;
__DATA__
};
}
1;
__END__

74
perl/grepdbg
View File

@ -25,6 +25,8 @@
require 5.004;
package main;
# search local then perl directories
BEGIN {
# root of directory tree for this system
@ -42,7 +44,7 @@ use Julian;
use strict;
use vars qw(@list $fp $today $string);
use vars qw(@days $fp $today $string);
$fp = DXLog::new('debug', 'dat', 'd');
@ -53,20 +55,21 @@ my @patt;
foreach my $arg (@ARGV) {
if ($arg =~ /^-/) {
$arg =~ s/^-//o;
if ($arg =~ /^\s*\-+(?:[h\?]e?l?p?)/) {
$arg =~ s/^-+//;
if ($arg =~ /\?|^he?l?p?/) {
usage();
exit(0);
}
push @list, $arg;
$nolines = $arg if $arg =~ /^\d+$/;
} elsif ($arg =~ /^\d+$/) {
$nolines = $arg;
push @days, $arg;
} elsif ($arg =~ /\.pm$/) {
if (-e $arg) {
my $fn = $arg;
$fn =~ s/\.pm$//;
eval { require $arg};
die "requiring $fn failed $@" if $@;
die "required $fn does not contain 'sub handle' (check that 'package main;' exists)" unless main->can('handle');
} else {
die "$arg not found";
}
@ -77,29 +80,31 @@ foreach my $arg (@ARGV) {
push @patt, '.*' unless @patt;
push @list, "0" unless @list;
for my $entry (@list) {
push @days, "0" unless @days;
for my $entry (@days) {
my $now = $today->sub($entry);
my $fh = $fp->open($now);
my $line;
my $do;
if (main->can('handle')) {
$do = \&handle;
} else {
$do = \&process;
}
begin() if main->can('begin');
if ($fh) {
while (<$fh>) {
&$do($_);
if (main->can('handle')) {
handle($_);
} else {
process($_);
}
}
$fp->close();
}
end() if main->can('end');
}
total() if main->can('total');
exit 0;
sub process
{
my $line = shift;
@ -121,14 +126,51 @@ sub process
s/([\x00-\x1f\x7f-\xff])/sprintf("\\x%02X", ord($1))/eg;
my ($t, $l) = split /\^/, $_, 2;
print atime($t), ' ', $l, "\n";
print '----------------' if $nolines > 1;
}
print "------------------\n" if $nolines > 1;
@prev = ();
}
}
sub usage
{
die "usage: grepdbg [nn days before] [-nnn lines before] [<perl file name>] [<regexp>|!<regexp>]...\n";
print << "XXX";
usage: grepdbg [nn days before] [-nnn lines before] [<perl file name>] [<regexp>|!<regexp>]...
grepdbg with no argumants will simply list the current debug log with the timestamp
for each line decoded into a human readable form.
grepdbg | less
is a handy way of scrolling through the debug log.
You can install your own content and display arrangement (useful for filtering data
in some complicated way). You call it like this (assuming it is called 'filter.pm').
grepdbg filter.pm
All the other arguments to grepdbg are available to limit the input to your filter.
If you want them.
The filter module MUST contain at least:
package main;
sub handle
{
your code goes here
}
1;
It can also have a 'sub begin {...}' and / or 'sub end {...}' which are executed
immediately after opening a logfile and then just before closing it, respectively.
You can also add a 'sub total {...}' which executes after the last line is
printed and grepdbg exits.
Read the code of this program and copy'n'paste the 'sub process' code and its name
to 'sub handle'. Modify it to your requirements...
XXX
}
exit(0);