From 2733a992ac8c3d315c110a2cc1984ea0a5e5d0ff Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Thu, 16 Jul 2020 23:07:28 +0100 Subject: [PATCH] Fix Filtering, RBN changes Filter has changed so that it is now a "simple" transliteration into perl expressions and relies on perl to do what is required It is quitely that some more work will be required for error handling, but the I no longer attempt to do any bracket handling and leave that up to perl. This means that brackets are fully working (as opposed to NOT working at all). Regexes are now robustly translated where necessary. In order to do this I have ditched Data Dumper because it did not seem to cope with the regex translations correctly. '\s' would seem have been translated to '\\s' and not what the regex actually said. So I have changed the file format to JSON. As this is now the 3rd or 4th JSON change I have made, I have created a "standard" encode and decode in DXJSON.pm and retrofitted it to all the other places which had their own purpose built one. DXJSON.pm is just a very light shim over the standard one. The RBN changes are: 1. don't short-circuit the zone iteration by a filter firing. 2. make sure that filtering and not filtering work identically 3. Add constants to the caches records to make it more obvious what is going on. --- cmd/show/dx.pl | 22 ++--- perl/DXJSON.pm | 62 ++++++++++++++ perl/DXUser.pm | 26 +----- perl/Filter.pm | 197 +++++++++++++++++++++++++------------------- perl/Messages | 2 +- perl/QSL.pm | 22 +---- perl/RBN.pm | 214 +++++++++++++++++++++++++++--------------------- perl/Spot.pm | 2 + perl/cluster.pl | 3 + perl/grepdbg | 32 +++++++- 10 files changed, 348 insertions(+), 234 deletions(-) create mode 100644 perl/DXJSON.pm diff --git a/cmd/show/dx.pl b/cmd/show/dx.pl index 5ebc1033..5387b7f4 100644 --- a/cmd/show/dx.pl +++ b/cmd/show/dx.pl @@ -12,18 +12,18 @@ sub handle my ($self, $line) = @_; # disguise regexes - $line =~ s/\{(.*)\}/'{'. unpack('H*', $1) . '}'/eg; + $line =~ s/\{(.*?)\}/'{'. unpack('H*', $1) . '}'/eg; dbg("sh/dx disguise any regex: '$line'") if isdbg('sh/dx'); # now space out brackets and ! $line =~ s/([\(\!\)])/ $1 /g; - my @list = split /[\s]+/, $line; # split the line up + my @list = split /\s+/, $line; # split the line up # put back the regexes @list = map { my $l = $_; $l =~ s/\{([0-9a-fA-F]+)\}/'{' . pack('H*', $1) . '}'/eg; $l } @list; - dbg("sh/dx after regex return: " . join(' ', @list)) if isdbg('sh/dx'); + dbg("sh/dx after regex return: '" . join(' ', @list) . "'") if isdbg('sh/dx'); my @out; my $f; @@ -40,10 +40,11 @@ sub handle my @flist; - dbg("sh/dx \@list: " . join(" ", @list)) if isdbg('sh/dx'); + dbg("sh/dx list: " . join(" ", @list)) if isdbg('sh/dx'); - while ($f = shift @list) { # next field - dbg "sh/dx arg: $f list: " . join(',', @list) if isdbg('sh/dx'); + while (@list) { # next field + $f = shift @list; + dbg("sh/dx arg: $f list: '" . join(',', @list) . "'") if isdbg('sh/dx'); if ($f && !$from && !$to) { ($from, $to) = $f =~ m|^(\d+)[-/](\d+)$| || (0,0); # is it a from -> to count? dbg("sh/dx from: $from to: $to") if isdbg('sh/dx'); @@ -57,7 +58,7 @@ sub handle } if (lc $f eq 'day' && $list[0]) { ($fromday, $today) = split m|[-/]|, shift(@list); - dbg "sh/dx got day $fromday/$today" if isdbg('sh/dx'); + dbg("sh/dx got day $fromday/$today") if isdbg('sh/dx'); next; } if (lc $f eq 'exact') { @@ -120,7 +121,7 @@ sub handle dbg("sh/dx operator $f") if isdbg('sh/dx'); next; } - if (grep {lc $f eq $_} qw(on freq call info spotter by dxcc call_dxcc by_dxcc bydxcc origin call_itu itu call_zone zone byitu by_itu by_zone byzone call_state state bystate by_state ip) ) { + if (grep {lc $f eq $_} qw(on freq call info spotter by dxcc call_dxcc by_dxcc bydxcc origin call_itu itu call_zone zone cq bycq byitu by_itu by_zone byzone call_state state bystate by_state ip) ) { push @flist, $f; push @flist, shift @list if @list; dbg("sh/dx function $flist[-2] $flist[-1]") if isdbg('sh/dx'); @@ -133,6 +134,7 @@ sub handle push @flist, $f; } + dbg("sh/dx: flist = '" . join(',', @flist). "'") if isdbg('sh/dx'); if ($pre) { # someone (probably me) has forgotten the 'info' keyword @@ -153,14 +155,14 @@ sub handle } my $newline = join(' ', @flist); - dbg("sh/dx newline: $newline") if isdbg('sh/dx'); + dbg("sh/dx newline: '$newline'") if isdbg('sh/dx'); my ($r, $filter, $fno, $user, $expr) = $Spot::filterdef->parse($self, 'spots', $newline, 1); return (0, "sh/dx parse error '$r' " . $filter) if $r; $user ||= ''; $expr ||= ''; - dbg "sh/dx user: $user expr: $expr from: $from to: $to fromday: $fromday today: $today" if isdbg('sh/dx'); + dbg("sh/dx user: $user expr: $expr from: $from to: $to fromday: $fromday today: $today") if isdbg('sh/dx'); # now do the search diff --git a/perl/DXJSON.pm b/perl/DXJSON.pm new file mode 100644 index 00000000..1a26f1aa --- /dev/null +++ b/perl/DXJSON.pm @@ -0,0 +1,62 @@ +# +# A light shim over JSON for DXSpider general purpose serialising +# +# Copyright (c) 2020 Dirk Koopman, G1TLH +# + +package DXJSON; + +use strict; +use warnings; + +use JSON; +use Data::Structure::Util qw(unbless); +use DXDebug; +use DXUtil; + +our @ISA = qw(JSON); + +sub new +{ + return shift->SUPER::new()->canonical(1); +} + +sub encode +{ + my $json = shift; + my $ref = shift; + my $name = ref $ref; + + unbless($ref) if $name && $name ne 'HASH'; + my $s; + + eval {$s = $json->SUPER::encode($ref) }; + if ($s && !$@) { + bless $ref, $name if $name && $name ne 'HASH'; + return $s; + } + else { + $s = dd($ref); + dbg "DXJSON::encode '$s' - $@"; + } +} + +sub decode +{ + my $json = shift; + my $s = shift; + my $name = shift; + + my $ref; + eval { $ref = $json->SUPER::decode($s) }; + if ($ref && !$@) { + return bless $ref, $name if $name; + return $ref; + } + else { + dbg "DXJSON::decode '$s' - $@"; + } + return undef; +} + +1; diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 267c68ed..8890fae9 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -20,7 +20,7 @@ use File::Copy; use Data::Structure::Util qw(unbless); use Time::HiRes qw(gettimeofday tv_interval); use IO::File; -use JSON; +use DXJSON; use strict; @@ -135,7 +135,7 @@ sub init { my $mode = shift; - $json = JSON->new->canonical(1); + $json = DXJSON->new->canonical(1); my $fn = "users"; $filename = localdata("$fn.v3j"); unless (-e $filename || $mode == 2) { @@ -309,31 +309,13 @@ sub put # thaw the user sub decode { - my $s = shift; - my $ref; - eval { $ref = $json->decode($s) }; - if ($ref && !$@) { - return bless $ref, 'DXUser'; - } else { - LogDbg('DXUser', "DXUser::json_decode: on '$s' $@"); - } - return undef; + return $json->decode(shift, __PACKAGE__); } # freeze the user sub encode { - my $ref = shift; - unbless($ref); - my $s; - - eval {$s = $json->encode($ref) }; - if ($s && !$@) { - bless $ref, 'DXUser'; - return $s; - } else { - LogDbg('DXUser', "DXUser::json_encode $ref->{call}, $@"); - } + return $json->encode(shift); } diff --git a/perl/Filter.pm b/perl/Filter.pm index a422b014..64d05508 100644 --- a/perl/Filter.pm +++ b/perl/Filter.pm @@ -31,6 +31,8 @@ use DXUtil; use DXDebug; use Data::Dumper; use Prefix; +use DXLog; +use DXJSON; use strict; @@ -38,11 +40,13 @@ use vars qw ($filterbasefn $in); $filterbasefn = "$main::root/filter"; $in = undef; +my $json; + # initial filter system sub init { - + $json = DXJSON->new->indent(1); } sub new @@ -88,6 +92,7 @@ sub compile if ($ref->{$ar} && exists $ref->{$ar}->{asc}) { my $s = $ref->{$ar}->{asc}; # an optimisation? $s =~ s/\$r/\$_[0]/g; +# $s =~ s/\\\\/\\/g; $ref->{$ar}->{code} = eval "sub { $s }" ; if ($@) { my $sort = $ref->{sort}; @@ -109,7 +114,12 @@ sub read_in if ($fn = getfn($sort, $call, $flag)) { $in = undef; my $s = readfilestr($fn); - my $newin = eval $s; + my $newin; + if ($s =~ /^\s*{/) { + eval {$newin = $json->decode($s, __PACKAGE__)}; + } else { + $newin = eval $s; + } if ($@) { dbg($@); unlink($fn); @@ -136,6 +146,46 @@ sub read_in return undef; } + +# this writes out the filter in a form suitable to be read in by 'read_in' +# It expects a list of references to filter lines +sub write +{ + my $self = shift; + my $sort = $self->{sort}; + my $name = $self->{name}; + my $dir = "$filterbasefn/$sort"; + my $fn = "$dir/$name"; + + mkdir $dir, 0775 unless -e $dir; + rename $fn, "$fn.o" if -e $fn; + my $fh = new IO::File ">$fn"; + if ($fh) { +# my $dd = new Data::Dumper([ $self ]); +# $dd->Indent(1); +# $dd->Terse(1); +# $dd->Quotekeys($] < 5.005 ? 1 : 0); + # $fh->print($dd->Dumpxs); + + # remove code references, do the encode, then put them back again (they can't be represented anyway) + my $key; + foreach $key ($self->getfilkeys) { + $self->{$key}->{reject}->{code} = undef if exists $self->{$key}->{reject}; + $self->{$key}->{accept}->{code} = undef if exists $self->{$key}->{accept}; + } + $fh->print($json->encode($self)); + foreach $key ($self->getfilkeys) { + $self->compile($key, 'reject'); + $self->compile($key, 'accept'); + } + $fh->close; + } else { + rename "$fn.o", $fn if -e "$fn.o"; + return "$fn $!"; + } + return undef; +} + sub getfilters { my $self = shift; @@ -244,33 +294,6 @@ sub it return ($r, $hops); } -# this writes out the filter in a form suitable to be read in by 'read_in' -# It expects a list of references to filter lines -sub write -{ - my $self = shift; - my $sort = $self->{sort}; - my $name = $self->{name}; - my $dir = "$filterbasefn/$sort"; - my $fn = "$dir/$name"; - - mkdir $dir, 0775 unless -e $dir; - rename $fn, "$fn.o" if -e $fn; - my $fh = new IO::File ">$fn"; - if ($fh) { - my $dd = new Data::Dumper([ $self ]); - $dd->Indent(1); - $dd->Terse(1); - $dd->Quotekeys($] < 5.005 ? 1 : 0); - $fh->print($dd->Dumpxs); - $fh->close; - } else { - rename "$fn.o", $fn if -e "$fn.o"; - return "$fn $!"; - } - return undef; -} - sub print { my $self = shift; @@ -353,6 +376,8 @@ sub delete } } + + package Filter::Cmd; use strict; @@ -362,6 +387,21 @@ use DXDebug; use vars qw(@ISA); @ISA = qw(Filter); +sub encode_regex +{ + my $s = shift; + $s =~ s/\{(.*?)\}/'{'. unpack('H*', $1) . '}'/eg if $s; + return $s; +} + +sub decode_regex +{ + my $r = shift; + my ($v) = $r =~ /^\{(.*?)}$/; + return pack('H*', $v); +} + + # the general purpose command processor # this is called as a subroutine not as a method sub parse @@ -381,16 +421,16 @@ sub parse $line = lc $line; # disguise regexes - $line =~ s/\{(.*)\}/'{'. unpack('H*', $1) . '}'/eg; + dbg("Filter parse line after regex check: '$line'") if isdbg('filter'); + $line = encode_regex($line); # add some spaces for ease of parsing $line =~ s/([\(\!\)])/ $1 /g; my @f = split /\s+/, $line; - - my $conj = ' && '; - my $not = ""; + dbg("filter parse: tokens '" . join("' '", @f) . "'") if isdbg('filter'); + my $lasttok = ''; while (@f) { if ($ntoken == 0) { @@ -419,65 +459,30 @@ sub parse # do the rest of the filter tokens if (@f) { my $tok = shift @f; - if ($tok eq '(') { - if ($s) { - unless ($lasttok eq '(') { - $s .= $conj ; - $user .= $conj; - } - $conj = ""; - $lasttok = $tok; - } - if ($not) { - $s .= $not; - $user .= $not; - $not = ""; - } - $s .= $tok; - $user .= $tok; - $lasttok = $tok; - next; - } elsif ($tok eq ')') { - $conj = ' && '; - $not =""; - $s .= $tok; - $user .= $tok; - $lasttok = $tok; - next; - } elsif ($tok eq 'all') { + + dbg("filter::parse: tok '$tok'") if isdbg('filter'); + + if ($tok eq 'all') { $s .= '1'; $user .= $tok; last; - } elsif ($tok eq 'or') { - $conj = ' || ' if $conj ne ' || '; - $lasttok = $tok; - next; - } elsif ($tok eq 'and') { - $conj = ' && ' if $conj ne ' && '; + } elsif (grep $tok eq $_, qw{and or not ( )}) { + $s .= ' && ' if $tok eq 'and'; + $s .= ' || ' if $tok eq 'or'; + $s .= ' !' if $tok eq 'not'; + $s .= $tok if $tok eq '(' or $tok eq ')'; + $user .= " $tok "; next; - } elsif ($tok eq 'not' || $tok eq '!') { - $not = '! '; - $lasttok = $tok; + } elsif ($tok eq '') { next; } + if (@f) { my $val = shift @f; my @val = split /,/, $val; - if ($s) { - unless ($lasttok eq '(') { - $s .= $conj ; - $user .= $conj; - $conj = ' && '; - } - } - if ($not) { - $s .= $not; - $user .= $not; - $not = ''; - } - - $user .= "$tok $val"; + dbg("filter::parse: tok '$tok' val '$val'") if isdbg('filter'); + $user .= " $tok $val"; my $fref; my $found; @@ -497,13 +502,17 @@ sub parse $v =~ s/\*//g; # remove any trailing * if (my ($r) = $v =~ /^\{(.*)\}$/) { # we have a regex dbg("Filter::parse regex b: '\{$r\}'") if isdbg('filter'); - $v = pack('H*', $r); + $v = decode_regex($v); dbg("Filter::parse regex a: '$v'") if isdbg('filter'); return ('regex', $dxchan->msg('e38', $v)) unless (qr{$v}); + push @t, "\$r->[$fref->[2]]=~m{$v}i"; + $v = "{$r}"; # put it back together again for humans + } else { + push @t, "\$r->[$fref->[2]]=~m{$v}i"; } - push @t, "\$r->[$fref->[2]]=~m{$v}i"; } $s .= "(" . join(' || ', @t) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] eq 'c') { my @t; for (@val) { @@ -511,6 +520,7 @@ sub parse push @t, "\$r->[$fref->[2]]=~m{^\U$_}"; } $s .= "(" . join(' || ', @t) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] eq 'n') { my @t; for (@val) { @@ -518,16 +528,19 @@ sub parse push @t, "\$r->[$fref->[2]]==$_"; } $s .= "(" . join(' || ', @t) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] =~ /^n[ciz]$/ ) { # for DXCC, ITU, CQ Zone my $cmd = $fref->[1]; my @pre = Prefix::to_ciz($cmd, @val); return ('numpre', $dxchan->msg('e27', $_)) unless @pre; $s .= "(" . join(' || ', map {"\$r->[$fref->[2]]==$_"} @pre) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] =~ /^ns$/ ) { # for DXCC, ITU, CQ Zone my $cmd = $fref->[1]; my @pre = Prefix::to_ciz($cmd, @val); return ('numpre', $dxchan->msg('e27', $_)) unless @pre; $s .= "(" . "!\$USDB::present || grep \$r->[$fref->[2]] eq \$_, qw(" . join(' ' ,map {uc} @pre) . "))"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] eq 'r') { my @t; for (@val) { @@ -535,6 +548,7 @@ sub parse push @t, "(\$r->[$fref->[2]]>=$1 && \$r->[$fref->[2]]<=$2)"; } $s .= "(" . join(' || ', @t) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } else { confess("invalid filter function $fref->[1]"); } @@ -542,9 +556,10 @@ sub parse last; } } - return (1, $dxchan->msg('e20', $tok)) unless $found; + return (1, $dxchan->msg('e20', $lasttok)) unless $found; } else { - return (1, $dxchan->msg('filter2', $tok)); + my $s = '{' . decode_regex($tok) . '}' if $tok =~ /^{.*}$/; + return (1, $dxchan->msg('filter2', $s)); } $lasttok = $tok; } @@ -552,11 +567,21 @@ sub parse # tidy up the user string (why I have to stick in an if statement when I have initialised it I have no idea! 5.28 bug? if ($user) { + $user =~ s/\)\s*\(/ and /g; $user =~ s/\&\&/ and /g; $user =~ s/\|\|/ or /g; $user =~ s/\!/ not /g; $user =~ s/\s+/ /g; + $user =~ s/\{(.*?)\}/'{'. pack('H*', $1) . '}'/eg; + $user =~ s/^\s+//; + dbg("filter parse: user '$user'") if isdbg('filter'); } + + if ($s) { + $s =~ s/\)\s*\(/ && /g; + dbg("filter parse: s '$s'") if isdbg('filter'); + } + return (0, $filter, $fno, $user, $s); } diff --git a/perl/Messages b/perl/Messages index d79eec73..5002908f 100644 --- a/perl/Messages +++ b/perl/Messages @@ -93,7 +93,7 @@ package DXM; e17 => 'Please don\'t use the words: @_ on here', e18 => 'Cannot connect to $_[0] ($!)', e19 => 'Invalid character in line', - e20 => 'token $_[0] not recognised', + e20 => qq{token '$_[0]' not recognised}, e21 => '$_[0] is not numeric', e22 => '$_[0] is not a callsign', e23 => '$_[0] is not a range (eg 0/30000)', diff --git a/perl/QSL.pm b/perl/QSL.pm index d10345ed..f62897bf 100644 --- a/perl/QSL.pm +++ b/perl/QSL.pm @@ -13,7 +13,7 @@ use DXUtil; use DB_File; use DXDebug; use Prefix; -use JSON; +use DXJSON; use Data::Structure::Util qw(unbless); use vars qw($qslfn $dbm $maxentries); @@ -31,7 +31,7 @@ sub init my $mode = shift; my $ufn = localdata("$qslfn.v1j"); - $json = JSON->new->canonical(1); + $json = DXJSON->new; Prefix::load() unless Prefix::loaded(); @@ -138,27 +138,13 @@ sub remove_files # thaw the user sub decode { - my $s = shift; - my $ref; - eval { $ref = $json->decode($s) }; - if ($ref && !$@) { - return bless $ref, 'QSL'; - } - return undef; + return $json->decode($_[0], __PACKAGE__); } # freeze the user sub encode { - my $ref = shift; - unbless($ref); - my $s; - - eval {$s = $json->encode($ref) }; - if ($s && !$@) { - bless $ref, 'QSL'; - return $s; - } + return $json->encode($_[0]); } 1; diff --git a/perl/RBN.pm b/perl/RBN.pm index 418c1cb3..8d5db6aa 100644 --- a/perl/RBN.pm +++ b/perl/RBN.pm @@ -11,6 +11,8 @@ package RBN; use 5.10.1; +use lib qw {.}; + use DXDebug; use DXUtil; use DXLog; @@ -18,11 +20,34 @@ use DXUser; use DXChannel; use Math::Round qw(nearest); use Date::Parse; -use Time::HiRes qw(clock_gettime CLOCK_REALTIME); +use Time::HiRes qw(gettimeofday); use Spot; -use JSON; +use DXJSON; use IO::File; +use constant { + ROrigin => 0, + RQrg => 1, + RCall => 2, + RMode => 3, + RStrength => 4, + RTime => 5, + RUtz => 6, + Respot => 7, + RQra => 8, + RSpotData => 9, + }; + +use constant { + SQrg => 0, + SCall => 1, + STime => 2, + SComment => 3, + SOrigin => 4, + SZone => 11, + }; + + our @ISA = qw(DXChannel); our $startup_delay = 5*60; # don't send anything out until this timer has expired @@ -53,7 +78,7 @@ my $noinrush = 0; # override the inrushpreventor if set sub init { - $json = JSON->new; + $json = DXJSON->new; $spots = {}; if (check_cache()) { $noinrush = 1; @@ -164,9 +189,6 @@ sub normal my @ans; # my $spots = $self->{spot}; - # save this for them's that need it - my $rawline = $line; - # remove leading and trailing spaces chomp $line; $line =~ s/^\s*//; @@ -254,6 +276,7 @@ sub normal # per second (limited by the test program's output and network speed, rather than DXSpider's handling). my $nqrg = nearest(1, $qrg); # normalised to nearest Khz +# my $nqrg = nearest_even($qrg); # normalised to nearest Khz my $sp = "$call|$nqrg"; # hopefully the skimmers will be calibrated at least this well! my $spp = sprintf("$call|%d", $nqrg+1); # but, clearly, my hopes are rudely dashed my $spm = sprintf("$call|%d", $nqrg-1); # in BOTH directions! @@ -286,7 +309,7 @@ sub normal # here we either have an existing spot record buildup on the go, or we need to create the first one unless ($spot) { - $spots->{$sp} = $spot = [clock_gettime(CLOCK_REALTIME)];; + $spots->{$sp} = $spot = [$main::systime]; dbg("RBN: key: '$sp' call: $call qrg: $qrg NEW" . ($respot ? ' RESPOT' : '')) if isdbg('rbn'); } @@ -301,7 +324,7 @@ sub normal # create record and add into the buildup my $r = [$origin, nearest(.1, $qrg), $call, $mode, $s, $t, $utz, $respot, $u]; - my @s = Spot::prepare($r->[1], $r->[2], $r->[6], '', $r->[0]); + my @s = Spot::prepare($r->[RQrg], $r->[RCall], $r->[RUtz], '', $r->[ROrigin]); if ($s[5] == 666) { dbg("RBN: ERROR invalid prefix/callsign $call from $origin-# on $qrg, dumped"); return; @@ -311,7 +334,7 @@ sub normal my ($want, undef) = $self->{inrbnfilter}->it($s); return unless $want; } - $r->[9] = \@s; + $r->[RSpotData] = \@s; push @{$self->{queue}}, $sp if @$spot == 1; # queue the KEY (not the record) @@ -320,7 +343,7 @@ sub normal push @$spot, $r; # At this point we run the queue to see if anything can be sent onwards to the punter - my $now = clock_gettime(CLOCK_REALTIME); + my $now = $main::systime; # now run the waiting queue which just contains KEYS ($call|$qrg) foreach $sp (@{$self->{queue}}) { @@ -342,7 +365,7 @@ sub normal $quality = 9 if $quality > 9; $quality = "Q:$quality"; if (isdbg('progress')) { - my $s = "RBN: SPOT key: '$sp' = $r->[2] on $r->[1] by $r->[0] \@ $r->[5] $quality"; + my $s = "RBN: SPOT key: '$sp' = $r->[RCall] on $r->[RQrg] by $r->[ROrigin] \@ $r->[RTime] $quality"; $s .= " route: $self->{call}"; dbg($s); } @@ -363,53 +386,6 @@ sub normal } } -sub per_minute -{ - foreach my $dxchan (DXChannel::get_all()) { - next unless $dxchan->is_rbn; - dbg "RBN:STATS minute $dxchan->{call} raw: $dxchan->{noraw} sent: $dxchan->{norbn} delivered: $dxchan->{nospot} users: " . scalar keys %{$dxchan->{nousers}} if isdbg('rbnstats'); - if ($dxchan->{noraw} == 0 && $dxchan->{lasttime} > 60) { - LogDbg('RBN', "RBN: no input from $dxchan->{call}, disconnecting"); - $dxchan->disconnect; - } - $dxchan->{noraw} = $dxchan->{norbn} = $dxchan->{nospot} = 0; $dxchan->{nousers} = {}; - $runtime{$dxchan->{call}} += 60; - } - - # save the spot cache - write_cache() unless $main::systime + $startup_delay < $main::systime;; -} - -sub per_10_minute -{ - my $count = 0; - my $removed = 0; - while (my ($k,$v) = each %{$spots}) { - if ($main::systime - $v->[0] > $minspottime*2) { - delete $spots->{$k}; - ++$removed; - } - else { - ++$count; - } - } - dbg "RBN:STATS spot cache remain: $count removed: $removed"; # if isdbg('rbn'); - foreach my $dxchan (DXChannel::get_all()) { - next unless $dxchan->is_rbn; - dbg "RBN:STATS 10-minute $dxchan->{call} raw: $dxchan->{noraw10} sent: $dxchan->{norbn10} delivered: $dxchan->{nospot10} users: " . scalar keys %{$dxchan->{nousers10}}; - $dxchan->{noraw10} = $dxchan->{norbn10} = $dxchan->{nospot10} = 0; $dxchan->{nousers10} = {}; - } -} - -sub per_hour -{ - foreach my $dxchan (DXChannel::get_all()) { - next unless $dxchan->is_rbn; - dbg "RBN:STATS hour $dxchan->{call} raw: $dxchan->{norawhour} sent: $dxchan->{norbnhour} delivered: $dxchan->{nospothour} users: " . scalar keys %{$dxchan->{nousershour}}; - $dxchan->{norawhour} = $dxchan->{norbnhour} = $dxchan->{nospothour} = 0; $dxchan->{nousershour} = {}; - } -} - # we should get the spot record minus the time, so just an array of record (arrays) sub send_dx_spot { @@ -474,45 +450,49 @@ sub dx_spot ++$self->{nousers}->{$call}; ++$self->{nousers10}->{$call}; ++$self->{nousershour}->{$call}; - + + my $filtered; + my $rf = $dxchan->{rbnfilter} || $dxchan->{spotsfilter}; foreach my $r (@$spot) { # $r = [$origin, $qrg, $call, $mode, $s, $t, $utz, $respot, $qra]; # Spot::prepare($qrg, $call, $utz, $comment, $origin); - my $comment = sprintf "%-3s %2ddB $quality", $r->[3], $r->[4]; - $respot = 1 if $r->[7]; - $qra = $r->[8] if !$qra && $r->[8] && is_qra($r->[8]); + my $comment = sprintf "%-3s %2ddB $quality", $r->[RMode], $r->[RStrength]; + $respot = 1 if $r->[Respot]; + $qra = $r->[RQra] if !$qra && $r->[RQra] && is_qra($r->[RQra]); - my $s = $r->[9]; # the prepared spot - $s->[3] = $comment; # apply new generated comment + my $s = $r->[RSpotData]; # the prepared spot + $s->[SComment] = $comment; # apply new generated comment - ++$zone{$s->[11]}; # save the spotter's zone - ++$qrg{$s->[0]}; # and the qrg + ++$zone{$s->[SZone]}; # save the spotter's zone + ++$qrg{$s->[SQrg]}; # and the qrg - my $want = 0; - my $rf = $dxchan->{rbnfilter} || $dxchan->{spotsfilter}; - if ($rf) { - ($want, undef) = $rf->it($s); - next unless $want; + # save the lowest strength one + if ($r->[RStrength] < $strength) { + $strength = $r->[RStrength]; $saver = $s; - dbg("RBN: FILTERED call: $s->[1] qrg: $s->[0] origin: $s->[4] dB: $r->[4]") if isdbg 'rbn'; - last; + dbg("RBN: STRENGTH spot: $s->[SCall] qrg: $s->[SQrg] origin: $s->[SOrigin] dB: $r->[RStrength] < $strength") if isdbg 'rbnll'; } - # save the lowest strength one - if ($r->[4] < $strength) { - $strength = $r->[4]; - $saver = $s; - dbg("RBN: STRENGTH call: $s->[1] qrg: $s->[0] origin: $s->[4] dB: $r->[4]") if isdbg 'rbn'; + if ($rf) { + my ($want, undef) = $rf->it($s); + dbg("RBN: FILTERING for $call spot: $s->[SCall] qrg: $s->[SQrg] origin: $s->[SOrigin] dB: $r->[RStrength] com: '$s->[SComment]' want: " . ($want ? 'YES':'NO')) if isdbg 'rbnll'; + next unless $want; + $filtered = $s; +# last; } } + if ($rf) { + $saver = $filtered; # if nothing passed the filter's lips then $saver == $filtered == undef ! + } + if ($saver) { my $buf; # create a zone list of spotters - delete $zone{$saver->[11]}; # remove this spotter's zone (leaving all the other zones) + delete $zone{$saver->[SZone]}; # remove this spotter's zone (leaving all the other zones) my $z = join ',', sort {$a <=> $b} keys %zone; # determine the most likely qrg and then set it @@ -523,23 +503,23 @@ sub dx_spot $fk = $k, $mv = $v if $v > $mv; ++$c; } - $saver->[0] = $fk; - $saver->[3] .= '*' if $c > 1; - $saver->[3] .= '+' if $respot; - $saver->[3] .= " Z:$z" if $z; + $saver->[SQrg] = $fk; + $saver->[SComment] .= '*' if $c > 1; + $saver->[SComment] .= '+' if $respot; + $saver->[SComment] .= " Z:$z" if $z; - dbg("RBN: SENDING call: $saver->[1] qrg: $saver->[0] origin: $saver->[4] $saver->[3]") if isdbg 'rbn'; + dbg("RBN: SENDING to $call spot: $saver->[SCall] qrg: $saver->[SQrg] origin: $saver->[SOrigin] $saver->[SComment]") if isdbg 'rbnll'; if ($dxchan->{ve7cc}) { - my $call = $saver->[4]; - $saver->[4] .= '-#'; + my $call = $saver->[SOrigin]; + $saver->[SOrigin] .= '-#'; $buf = VE7CC::dx_spot($dxchan, @$saver); - $saver->[4] = $call; + $saver->[SOrigin] = $call; } else { - my $call = $saver->[4]; - $saver->[4] = substr($call, 0, 6); - $saver->[4] .= '-#'; + my $call = $saver->[SOrigin]; + $saver->[SOrigin] = substr($call, 0, 6); + $saver->[SOrigin] .= '-#'; $buf = $dxchan->format_dx_spot(@$saver); - $saver->[4] = $call; + $saver->[SOrigin] = $call; } # $buf =~ s/^DX/RB/; $dxchan->local_send('N', $buf); @@ -549,16 +529,64 @@ sub dx_spot ++$self->{nospothour}; if ($qra) { - my $user = DXUser::get_current($saver->[1]) || DXUser->new($saver->[1]); + my $user = DXUser::get_current($saver->[SCall]) || DXUser->new($saver->[SCall]); unless ($user->qra && is_qra($user->qra)) { $user->qra($qra); - dbg("RBN: update qra on $saver->[1] to $qra"); + dbg("RBN: update qra on $saver->[SCall] to $qra"); $user->put; } } } } + +sub per_minute +{ + foreach my $dxchan (DXChannel::get_all()) { + next unless $dxchan->is_rbn; + dbg "RBN:STATS minute $dxchan->{call} raw: $dxchan->{noraw} sent: $dxchan->{norbn} delivered: $dxchan->{nospot} users: " . scalar keys %{$dxchan->{nousers}} if isdbg('rbnstats'); + if ($dxchan->{noraw} == 0 && $dxchan->{lasttime} > 60) { + LogDbg('RBN', "RBN: no input from $dxchan->{call}, disconnecting"); + $dxchan->disconnect; + } + $dxchan->{noraw} = $dxchan->{norbn} = $dxchan->{nospot} = 0; $dxchan->{nousers} = {}; + $runtime{$dxchan->{call}} += 60; + } + + # save the spot cache + write_cache() unless $main::systime + $startup_delay < $main::systime;; +} + +sub per_10_minute +{ + my $count = 0; + my $removed = 0; + while (my ($k,$v) = each %{$spots}) { + if ($main::systime - $v->[0] > $minspottime*2) { + delete $spots->{$k}; + ++$removed; + } + else { + ++$count; + } + } + dbg "RBN:STATS spot cache remain: $count removed: $removed"; # if isdbg('rbn'); + foreach my $dxchan (DXChannel::get_all()) { + next unless $dxchan->is_rbn; + dbg "RBN:STATS 10-minute $dxchan->{call} raw: $dxchan->{noraw10} sent: $dxchan->{norbn10} delivered: $dxchan->{nospot10} users: " . scalar keys %{$dxchan->{nousers10}}; + $dxchan->{noraw10} = $dxchan->{norbn10} = $dxchan->{nospot10} = 0; $dxchan->{nousers10} = {}; + } +} + +sub per_hour +{ + foreach my $dxchan (DXChannel::get_all()) { + next unless $dxchan->is_rbn; + dbg "RBN:STATS hour $dxchan->{call} raw: $dxchan->{norawhour} sent: $dxchan->{norbnhour} delivered: $dxchan->{nospothour} users: " . scalar keys %{$dxchan->{nousershour}}; + $dxchan->{norawhour} = $dxchan->{norbnhour} = $dxchan->{nospothour} = 0; $dxchan->{nousershour} = {}; + } +} + sub finish { write_cache(); diff --git a/perl/Spot.pm b/perl/Spot.pm index 9fcf3280..763c60bd 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -48,11 +48,13 @@ $filterdef = bless ([ ['call_itu', 'ni', 8], ['itu', 'ni', 8], ['call_zone', 'nz', 9], + ['cq', 'nz', 9], ['zone', 'nz', 9], ['by_itu', 'ni', 10], ['byitu', 'ni', 10], ['by_zone', 'nz', 11], ['byzone', 'nz', 11], + ['bycq', 'nz', 11], ['call_state', 'ns', 12], ['state', 'ns', 12], ['by_state', 'ns', 13], diff --git a/perl/cluster.pl b/perl/cluster.pl index 2f1baf46..a38e5a10 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -563,6 +563,9 @@ sub setup_start dbg("loading user file system ..."); DXUser::init(4); # version 4 == json format + Filter::init(); # doesn't do much, but has to be done + + # look for the sysop and the alias user and complain if they aren't there { die "\$myalias \& \$mycall are the same ($mycall)!, they must be different (hint: make \$mycall = '${mycall}-2';). Oh and don't forget to rerun create_sysop.pl!" if $mycall eq $myalias; diff --git a/perl/grepdbg b/perl/grepdbg index f133a143..80a918a0 100755 --- a/perl/grepdbg +++ b/perl/grepdbg @@ -5,7 +5,6 @@ # # grepdbg [nn] [-mm] # - # nn - is the day you what to look at: 1 is yesterday, 0 is today # and is optional if there is only one argument # @@ -15,6 +14,11 @@ # is the regular expression you are searching for, # a caseless search is done # +# If you specify something that likes a filename and that filename +# has a .pm on the end of it and it exists then rather than doing +# the regex match it executes the "main::handle()" function passing +# it one line at a time. +# # require 5.004; @@ -54,6 +58,15 @@ for my $arg (@ARGV) { push @list, $arg; } elsif ($arg =~ /^\d+$/) { $nolines = $arg; + } elsif ($arg =~ /\.pm$/) { + if (-e $arg) { + my $fn = $arg; + $fn =~ s/\.pm$//; + eval { require $arg}; + die "requiring $fn failed $@" if $@; + } else { + die "$arg not found"; + } } else { $string = $arg; last; @@ -67,12 +80,22 @@ for my $entry (@list) { 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>) { - process($_); + &$do($_); } $fp->close(); } + end() if main->can('end'); } sub process @@ -85,7 +108,8 @@ sub process for (@prev) { s/([\x00-\x1f\x7f-\xff])/sprintf("\\x%02X", ord($1))/eg; my ($t, $l) = split /\^/, $_, 2; - print atime($t), ' ', $l, "\n"; + print atime($t), ' ', $l, "\n"; + print '----------------' if $nolines > 1; } @prev = (); } @@ -93,6 +117,6 @@ sub process sub usage { - die "usage: grepdbg [nn] [[-nnn] ..] \n"; + die "usage: grepdbg [nn days before] [-nnn lines before] [|]\n"; } exit(0); -- 2.34.1