From f653700decb8864d66aa45f849ab6796442171c4 Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Tue, 25 Jan 2022 14:42:32 +0000 Subject: [PATCH] fix grepdbg so it does what grepdbg -h says --- Changes | 2 + cmd/export_users.pl | 3 +- perl/DXUser.pm | 270 +++++++++++++++++++++++--------------------- perl/grepdbg | 78 ++++++++++--- 4 files changed, 204 insertions(+), 149 deletions(-) diff --git a/Changes b/Changes index a9b75993..5782bf2f 100644 --- a/Changes +++ b/Changes @@ -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. diff --git a/cmd/export_users.pl b/cmd/export_users.pl index a8cec7de..d03f1e0e 100644 --- a/cmd/export_users.pl +++ b/cmd/export_users.pl @@ -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)); diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 96751c91..911f35bc 100644 --- a/perl/DXUser.pm +++ b/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 = ; - 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 () { - 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 = ; + 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 () { + 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__ diff --git a/perl/grepdbg b/perl/grepdbg index 06f7df63..80a4b9de 100755 --- a/perl/grepdbg +++ b/perl/grepdbg @@ -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; @@ -115,20 +120,57 @@ sub process last unless $line =~ m{$p}i; } ++$flag; - } + } if ($flag == @patt) { for (@prev) { 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] [] [|!]...\n"; + print << "XXX"; + + usage: grepdbg [nn days before] [-nnn lines before] [] [|!]... + + 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); -- 2.43.0