mirror of
git://scm.dxcluster.org/scm/spider
synced 2024-09-21 07:47:10 +00:00
fix grepdbg so it does what grepdbg -h says
This commit is contained in:
parent
48f0cb90d0
commit
f653700dec
2
Changes
2
Changes
@ -1,3 +1,5 @@
|
|||||||
|
25Jan22=======================================================================
|
||||||
|
1. Fixed grepdbg so that it does what -help says it does.
|
||||||
21Jan22=======================================================================
|
21Jan22=======================================================================
|
||||||
1. downgrade console.pl require to perl 5.8.1.
|
1. downgrade console.pl require to perl 5.8.1.
|
||||||
2. Backport grepdbg from mojo.
|
2. Backport grepdbg from mojo.
|
||||||
|
@ -8,5 +8,4 @@ my $line = shift || "$main::data/user_asc";
|
|||||||
return (1, $self->msg('e5')) unless $self->priv >= 9;
|
return (1, $self->msg('e5')) unless $self->priv >= 9;
|
||||||
|
|
||||||
my ($fn, $flag) = split /\s+/, $line;
|
my ($fn, $flag) = split /\s+/, $line;
|
||||||
my $strip = $flag eq 'strip';
|
return (1, DXUser::export($fn));
|
||||||
return (1, DXUser::export($fn, $strip));
|
|
||||||
|
270
perl/DXUser.pm
270
perl/DXUser.pm
@ -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
|
# group handling
|
||||||
#
|
#
|
||||||
@ -862,6 +733,147 @@ sub lastping
|
|||||||
$b->{$call} = shift if @_;
|
$b->{$call} = shift if @_;
|
||||||
return $b->{$call};
|
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;
|
1;
|
||||||
__END__
|
__END__
|
||||||
|
|
||||||
|
78
perl/grepdbg
78
perl/grepdbg
@ -25,6 +25,8 @@
|
|||||||
|
|
||||||
require 5.004;
|
require 5.004;
|
||||||
|
|
||||||
|
package main;
|
||||||
|
|
||||||
# search local then perl directories
|
# search local then perl directories
|
||||||
BEGIN {
|
BEGIN {
|
||||||
# root of directory tree for this system
|
# root of directory tree for this system
|
||||||
@ -42,7 +44,7 @@ use Julian;
|
|||||||
|
|
||||||
use strict;
|
use strict;
|
||||||
|
|
||||||
use vars qw(@list $fp $today $string);
|
use vars qw(@days $fp $today $string);
|
||||||
|
|
||||||
|
|
||||||
$fp = DXLog::new('debug', 'dat', 'd');
|
$fp = DXLog::new('debug', 'dat', 'd');
|
||||||
@ -53,20 +55,21 @@ my @patt;
|
|||||||
|
|
||||||
foreach my $arg (@ARGV) {
|
foreach my $arg (@ARGV) {
|
||||||
if ($arg =~ /^-/) {
|
if ($arg =~ /^-/) {
|
||||||
$arg =~ s/^-//o;
|
$arg =~ s/^-+//;
|
||||||
if ($arg =~ /^\s*\-+(?:[h\?]e?l?p?)/) {
|
if ($arg =~ /\?|^he?l?p?/) {
|
||||||
usage();
|
usage();
|
||||||
exit(0);
|
exit(0);
|
||||||
}
|
}
|
||||||
push @list, $arg;
|
$nolines = $arg if $arg =~ /^\d+$/;
|
||||||
} elsif ($arg =~ /^\d+$/) {
|
} elsif ($arg =~ /^\d+$/) {
|
||||||
$nolines = $arg;
|
push @days, $arg;
|
||||||
} elsif ($arg =~ /\.pm$/) {
|
} elsif ($arg =~ /\.pm$/) {
|
||||||
if (-e $arg) {
|
if (-e $arg) {
|
||||||
my $fn = $arg;
|
my $fn = $arg;
|
||||||
$fn =~ s/\.pm$//;
|
$fn =~ s/\.pm$//;
|
||||||
eval { require $arg};
|
eval { require $arg};
|
||||||
die "requiring $fn failed $@" if $@;
|
die "requiring $fn failed $@" if $@;
|
||||||
|
die "required $fn does not contain 'sub handle' (check that 'package main;' exists)" unless main->can('handle');
|
||||||
} else {
|
} else {
|
||||||
die "$arg not found";
|
die "$arg not found";
|
||||||
}
|
}
|
||||||
@ -77,29 +80,31 @@ foreach my $arg (@ARGV) {
|
|||||||
|
|
||||||
push @patt, '.*' unless @patt;
|
push @patt, '.*' unless @patt;
|
||||||
|
|
||||||
push @list, "0" unless @list;
|
push @days, "0" unless @days;
|
||||||
for my $entry (@list) {
|
for my $entry (@days) {
|
||||||
my $now = $today->sub($entry);
|
my $now = $today->sub($entry);
|
||||||
my $fh = $fp->open($now);
|
my $fh = $fp->open($now);
|
||||||
my $line;
|
my $line;
|
||||||
my $do;
|
my $do;
|
||||||
|
|
||||||
if (main->can('handle')) {
|
|
||||||
$do = \&handle;
|
|
||||||
} else {
|
|
||||||
$do = \&process;
|
|
||||||
}
|
|
||||||
|
|
||||||
begin() if main->can('begin');
|
begin() if main->can('begin');
|
||||||
if ($fh) {
|
if ($fh) {
|
||||||
while (<$fh>) {
|
while (<$fh>) {
|
||||||
&$do($_);
|
if (main->can('handle')) {
|
||||||
|
handle($_);
|
||||||
|
} else {
|
||||||
|
process($_);
|
||||||
|
}
|
||||||
}
|
}
|
||||||
$fp->close();
|
$fp->close();
|
||||||
}
|
}
|
||||||
end() if main->can('end');
|
end() if main->can('end');
|
||||||
}
|
}
|
||||||
|
|
||||||
|
total() if main->can('total');
|
||||||
|
exit 0;
|
||||||
|
|
||||||
sub process
|
sub process
|
||||||
{
|
{
|
||||||
my $line = shift;
|
my $line = shift;
|
||||||
@ -115,20 +120,57 @@ sub process
|
|||||||
last unless $line =~ m{$p}i;
|
last unless $line =~ m{$p}i;
|
||||||
}
|
}
|
||||||
++$flag;
|
++$flag;
|
||||||
}
|
}
|
||||||
if ($flag == @patt) {
|
if ($flag == @patt) {
|
||||||
for (@prev) {
|
for (@prev) {
|
||||||
s/([\x00-\x1f\x7f-\xff])/sprintf("\\x%02X", ord($1))/eg;
|
s/([\x00-\x1f\x7f-\xff])/sprintf("\\x%02X", ord($1))/eg;
|
||||||
my ($t, $l) = split /\^/, $_, 2;
|
my ($t, $l) = split /\^/, $_, 2;
|
||||||
print atime($t), ' ', $l, "\n";
|
print atime($t), ' ', $l, "\n";
|
||||||
print '----------------' if $nolines > 1;
|
|
||||||
}
|
}
|
||||||
|
print "------------------\n" if $nolines > 1;
|
||||||
@prev = ();
|
@prev = ();
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
sub usage
|
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);
|
|
||||||
|
Loading…
Reference in New Issue
Block a user