From 88665a2bed3b9ec9e97237938a95a045b2a21bb4 Mon Sep 17 00:00:00 2001 From: djk Date: Sun, 11 Jun 2000 12:58:32 +0000 Subject: [PATCH] put duplicate checking into respective modules and out of DXProt. fix displaying of lines with | in them on console.pl added debugging show/(wwv|spot|ann)_dups.pl commands added AnnTalk module --- Changes | 5 ++ cmd/announce.pl | 1 + cmd/dx.pl | 6 +++ cmd/show/ann_dups.pl | 11 +++++ cmd/show/spot_dups.pl | 11 +++++ cmd/show/wwv_dups.pl | 11 +++++ perl/AnnTalk.pm | 57 +++++++++++++++++++++++ perl/DXCommandmode.pm | 1 + perl/DXProt.pm | 104 ++++++++++++------------------------------ perl/DXUtil.pm | 15 +++++- perl/Geomag.pm | 48 +++++++++++++++++-- perl/Messages | 1 + perl/Spot.pm | 56 +++++++++++++++++++++-- perl/client.pl | 2 +- perl/cluster.pl | 8 ++-- perl/console.pl | 2 +- 16 files changed, 249 insertions(+), 90 deletions(-) create mode 100644 cmd/show/ann_dups.pl create mode 100644 cmd/show/spot_dups.pl create mode 100644 cmd/show/wwv_dups.pl create mode 100644 perl/AnnTalk.pm diff --git a/Changes b/Changes index 4ee08fec..ac945e95 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,10 @@ 11Jun00======================================================================= 1. removed extraneous DXDebug from DXUtil +2. added help for set/echo +3. Centralised all spot, wwv and ann dup handling into respective packages. +4. Created new AnnTalk package (for above and OOing announce and talk +handling). +5. Fixed problem with outputting lines with | in them to console.pl. 10Jun00======================================================================= 1. got rid of some more nasty bugs in sh/qra. 2. fixed 9A3xx to always be Croatia (and not Haiti!). diff --git a/cmd/announce.pl b/cmd/announce.pl index 12017039..94b03a47 100644 --- a/cmd/announce.pl +++ b/cmd/announce.pl @@ -46,6 +46,7 @@ if ($sort eq "FULL") { # change ^ into : for transmission $line =~ s/\^/:/og; +return (1, $self->msg('dup')) if AnnTalk::dup($from, $to, $line); Log('ann', $to, $from, $line); DXProt::broadcast_list("To $to de $from <$t>: $line", 'ann', undef, @locals); if ($to ne "LOCAL") { diff --git a/cmd/dx.pl b/cmd/dx.pl index 7684542e..5e9eec1c 100644 --- a/cmd/dx.pl +++ b/cmd/dx.pl @@ -100,6 +100,7 @@ if (grep $_ eq $spotted, @DXProt::baddx) { my $buf = Spot::formatb($freq, $spotted, $main::systime, $line, $spotter); push @out, $buf; } else { + return (1, $self->msg('dup')) if Spot::dup($freq, $spotted, $main::systime, $line); my @spot = Spot::add($freq, $spotted, $main::systime, $line, $spotter, $main::mycall); if (@spot) { # send orf to the users @@ -108,3 +109,8 @@ if (grep $_ eq $spotted, @DXProt::baddx) { } return (1, @out); + + + + + diff --git a/cmd/show/ann_dups.pl b/cmd/show/ann_dups.pl new file mode 100644 index 00000000..26428c1b --- /dev/null +++ b/cmd/show/ann_dups.pl @@ -0,0 +1,11 @@ +# +# show a list of all the outstanding spot dups +# for debugging really +# +# Copyright (c) 2000 Dirk Koopman G1TLH +# +# $Id$ +# +my $self = shift; +return (1, $self->msg('e5')) unless $self->priv >= 9; +return (1, AnnTalk::listdups); diff --git a/cmd/show/spot_dups.pl b/cmd/show/spot_dups.pl new file mode 100644 index 00000000..5bd9b174 --- /dev/null +++ b/cmd/show/spot_dups.pl @@ -0,0 +1,11 @@ +# +# show a list of all the outstanding spot dups +# for debugging really +# +# Copyright (c) 2000 Dirk Koopman G1TLH +# +# $Id$ +# +my $self = shift; +return (1, $self->msg('e5')) unless $self->priv >= 9; +return (1, Spot::listdups); diff --git a/cmd/show/wwv_dups.pl b/cmd/show/wwv_dups.pl new file mode 100644 index 00000000..bf0cbe75 --- /dev/null +++ b/cmd/show/wwv_dups.pl @@ -0,0 +1,11 @@ +# +# show a list of all the outstanding spot dups +# for debugging really +# +# Copyright (c) 2000 Dirk Koopman G1TLH +# +# $Id$ +# +my $self = shift; +return (1, $self->msg('e5')) unless $self->priv >= 9; +return (1, Geomag::listdups); diff --git a/perl/AnnTalk.pm b/perl/AnnTalk.pm new file mode 100644 index 00000000..b082c385 --- /dev/null +++ b/perl/AnnTalk.pm @@ -0,0 +1,57 @@ +# +# Announce and Talk Handling routines +# +# Copyright (c) 2000 Dirk Koopman +# +# $Id$ +# + +package AnnTalk; + +use strict; + +use DXUtil; +use DXDebug; + +use vars qw(%dup $duplth $dupage); + +%dup = (); # the duplicates hash +$duplth = 60; # the length of text to use in the deduping +$dupage = 24*3600; # the length of time to hold spot dups + +# enter the spot for dup checking and return true if it is already a dup +sub dup +{ + my ($call, $to, $text) = @_; + my $d = $main::systime / 60; + + chomp $text; + unpad($text); + $text = substr($text, 0, $duplth) if length $text > $duplth; + my $dupkey = "$call|$to|$text"; + return 1 if exists $dup{$dupkey}; + $dup{$dupkey} = $d * 60; # in seconds (to the nearest minute) + return 0; +} + +# called every hour and cleans out the dup cache +sub process +{ + my $cutoff = $main::systime - $dupage; + while (my ($key, $val) = each %dup) { + delete $dup{$key} if $val < $cutoff; + } +} + +sub listdups +{ + my @out; + for (sort { $dup{$a} <=> $dup{$b} } keys %dup) { + my $val = $dup{$_}; + push @out, "$_ = $val (" . cldatetime($val) . ")"; + } + return @out; +} + +1; + diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 4a1acbba..b76493db 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -26,6 +26,7 @@ use CmdAlias; use Filter; use Minimuf; use DXDb; +use AnnTalk; use Sun; use strict; diff --git a/perl/DXProt.pm b/perl/DXProt.pm index aacd5660..936ba90a 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -25,27 +25,21 @@ use DXDebug; use Filter; use Local; use DXDb; +use AnnTalk; +use Geomag; use Time::HiRes qw(gettimeofday tv_interval); use strict; -use vars qw($me $pc11_max_age $pc23_max_age $pc11_dup_age $pc23_dup_age - %spotdup %wwvdup $last_hour %pings %rcmds $pc11duptext - %nodehops @baddx $baddxfn $pc12_dup_age - %anndup $allowzero $pc12_dup_lth $decode_dk0wcy); +use vars qw($me $pc11_max_age $pc23_max_age + $last_hour %pings %rcmds + %nodehops @baddx $baddxfn + $allowzero $decode_dk0wcy); $me = undef; # the channel id for this cluster $decode_dk0wcy = undef; # if set use this callsign to decode announces from the EU WWV data beacon $pc11_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc11 $pc23_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc23 -$pc11_dup_age = 3*3600; # the maximum time to keep the spot dup list for -$pc23_dup_age = 3*3600; # the maximum time to keep the wwv dup list for -$pc12_dup_age = 24*3600; # the maximum time to keep the ann dup list for -$pc12_dup_lth = 60; # the length of ANN text to save for deduping -$pc11duptext = 20; # maximum lth of the text field in PC11 to use for duduping - -%spotdup = (); # the pc11 and 26 dup hash -%wwvdup = (); # the pc23 and 27 dup hash -%anndup = (); # the PC12 dup hash + $last_hour = time; # last time I did an hourly periodic update %pings = (); # outstanding ping requests outbound %rcmds = (); # outstanding rcmd requests outbound @@ -66,22 +60,13 @@ sub init confess $@ if $@; # $me->{sort} = 'M'; # M for me - # now prime the spot duplicates file with today's and yesterday's data + # now prime the spot and wwv duplicates file with data my @today = Julian::unixtoj(time); - my @spots = Spot::readfile(@today); - @today = Julian::sub(@today, 1); - push @spots, Spot::readfile(@today); - for (@spots) { - my $duptext = length $_->[3] > $pc11duptext ? substr($_->[3], 0, $pc11duptext) : $_->[3] ; - my $dupkey = "$_->[0]$_->[1]$_->[2]$duptext$_->[4]"; - $spotdup{$dupkey} = $_->[2]; + for (Spot::readfile(@today), Spot::readfile(Julian::sub(@today, 1))) { + Spot::dup(@{$_}[0..3]); } - - # now prime the wwv duplicates file with just this month's data - my @wwv = Geomag::readfile(time); - for (@wwv) { - my $dupkey = "$_->[1].$_->[2]$_->[3]$_->[4]"; - $wwvdup{$dupkey} = $_->[1]; + for (Geomag::readfile(time)) { + Geomag::dup(@{$_}[1..5]); } # load the baddx file @@ -230,24 +215,6 @@ sub normal return; } - # strip off the leading & trailing spaces from the comment - my $duptext = length $field[5] > $pc11duptext ? substr($field[5], 0, $pc11duptext) : $field[5]; - my $text = unpad($field[5]); - - # store it away - my $spotter = $field[6]; - $spotter =~ s/-[\@\d]+$//o; # strip off the ssid from the spotter - - # do some de-duping - my $freq = $field[1] - 0; - my $dupkey = "$freq$field[2]$d$duptext$spotter"; - if ($spotdup{$dupkey}) { - dbg('chan', "Duplicate Spot ignored\n"); - return; - } - - $spotdup{$dupkey} = $d; - # is it 'baddx' if (grep $field[2] eq $_, @baddx) { dbg('chan', "Bad DX spot, ignored"); @@ -260,7 +227,13 @@ sub normal return; } - my @spot = Spot::add($freq, $field[2], $d, $text, $spotter, $field[7]); + # do some de-duping + if (Spot::dup($field[1], $field[2], $d, $field[5])) { + dbg('chan', "Duplicate Spot ignored\n"); + return; + } + + my @spot = Spot::add($field[1], $field[2], $d, $field[5], $field[6], $field[7]); # # @spot at this point contains:- @@ -287,13 +260,10 @@ sub normal if ($pcno == 12) { # announces # announce duplicate checking - my $text = substr(uc unpad($field[3]), 0, $pc12_dup_lth); - my $dupkey = $field[1].$field[2].$text; - if ($anndup{$dupkey}) { + if (AnnTalk::dup($field[1], $field[2], $field[3])) { dbg('chan', "Duplicate Announce ignored\n"); return; } - $anndup{$dupkey} = $main::systime; if ($field[2] eq '*' || $field[2] eq $main::mycall) { @@ -531,17 +501,15 @@ sub normal my $i = unpad($field[5]); my ($r) = $field[6] =~ /R=(\d+)/; $r = 0 unless $r; - my $dupkey = "$d.$sfi$k$i"; - if ($wwvdup{$dupkey}) { - dbg('chan', "Dup WWV Spot ignored\n"); - return; - } if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $field[2] < 0 || $field[2] > 23) { dbg('chan', "WWV Date ($field[1] $field[2]) out of range"); return; } - $wwvdup{$dupkey} = $d; - $field[6] =~ s/-\d+$//o; # remove spotter's ssid + if (Geomag::dup($d,$sfi,$k,$i,$field[6])) { + dbg('chan', "Dup WWV Spot ignored\n"); + return; + } + $field[7] =~ s/-\d+$//o; # remove spotter's ssid my $wwv = Geomag::update($d, $field[2], $sfi, $k, $i, @field[6..8], $r); @@ -798,18 +766,9 @@ sub process my $val; my $cutoff; if ($main::systime - 3600 > $last_hour) { - $cutoff = $main::systime - $pc11_dup_age; - while (($key, $val) = each %spotdup) { - delete $spotdup{$key} if $val < $cutoff; - } - $cutoff = $main::systime - $pc23_dup_age; - while (($key, $val) = each %wwvdup) { - delete $wwvdup{$key} if $val < $cutoff; - } - $cutoff = $main::systime - $pc12_dup_age; - while (($key, $val) = each %anndup) { - delete $anndup{$key} if $val < $cutoff; - } + Spot::process; + Geomag::process; + AnnTalk::process; $last_hour = $main::systime; } } @@ -1218,13 +1177,6 @@ sub load_hops return 0; } -# remove leading and trailing spaces from an input string -sub unpad -{ - my $s = shift; - $s =~ s/^\s+|\s+$//; - return $s; -} # add a ping request to the ping queues sub addping diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 7be97ebf..aad46965 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -16,7 +16,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf parray parraypairs shellregex readfilestr writefilestr - print_all_fields cltounix iscallsign + print_all_fields cltounix iscallsign unpad ); @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); @@ -279,3 +279,16 @@ sub writefilestr $fh->close; } } + +# remove leading and trailing spaces from an input string +sub unpad +{ + my $s = shift; + $s =~ s/^\s+|\s+$//; + return $s; +} + + + + + diff --git a/perl/Geomag.pm b/perl/Geomag.pm index ca16e363..e84e5d50 100644 --- a/perl/Geomag.pm +++ b/perl/Geomag.pm @@ -18,7 +18,9 @@ use IO::File; use DXDebug; use strict; -use vars qw($date $sfi $k $a $r $forecast @allowed @denied $fp $node $from); +use vars qw($date $sfi $k $a $r $forecast @allowed @denied $fp $node $from + $dirprefix $param + %dup $duplth $dupage); $fp = 0; # the DXLog fcb $date = 0; # the unix time of the WWV (notional) @@ -31,8 +33,12 @@ $node = ""; # originating node $from = ""; # who this came from @allowed = (); # if present only these callsigns are regarded as valid WWV updators @denied = (); # if present ignore any wwv from these callsigns -my $dirprefix = "$main::data/wwv"; -my $param = "$dirprefix/param"; +%dup = (); # the spot duplicates hash +$duplth = 20; # the length of text to use in the deduping +$dupage = 12*3600; # the length of time to hold spot dups + +$dirprefix = "$main::data/wwv"; +$param = "$dirprefix/param"; sub init { @@ -238,5 +244,41 @@ sub readfile } return @in; } + +# enter the spot for dup checking and return true if it is already a dup +sub dup +{ + my ($d, $sfi, $k, $a, $text) = @_; + + # dump if too old + return 2 if $d < $main::systime - $dupage; + + $d /= 60; # to the nearest minute + chomp $text; + $text = substr($text, 0, $duplth) if length $text > $duplth; + my $dupkey = "$d|$sfi|$k|$a|$text"; + return 1 if exists $dup{$dupkey}; + $dup{$dupkey} = $d * 60; # in seconds (to the nearest minute) + return 0; +} + +# called every hour and cleans out the dup cache +sub process +{ + my $cutoff = $main::systime - $dupage; + while (my ($key, $val) = each %dup) { + delete $dup{$key} if $val < $cutoff; + } +} + +sub listdups +{ + my @out; + for (sort { $dup{$a} <=> $dup{$b} } keys %dup) { + my $val = $dup{$_}; + push @out, "$_ = $val (" . cldatetime($val) . ")"; + } + return @out; +} 1; __END__; diff --git a/perl/Messages b/perl/Messages index 8fe2c1e8..c2baab8e 100644 --- a/perl/Messages +++ b/perl/Messages @@ -36,6 +36,7 @@ package DXM; db9 => 'Database $_[0] removed', db10 => '$_[0] records imported into $_[1]', db11 => 'Sending your request(s) to $_[0], please stand by...', + dup => 'Sorry, this is a duplicate', dx1 => 'Frequency $_[0] not in band (see show/band); usage: DX [BY call] freq call comments', dx2 => 'Need a callsign; usage: DX [BY call] freq call comments', dxs => 'DX Spots flag set on $_[0]', diff --git a/perl/Spot.pm b/perl/Spot.pm index 362e7d5e..afc3410f 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -17,13 +17,16 @@ use Julian; use Prefix; use strict; -use vars qw($fp $maxspots $defaultspots $maxdays $dirprefix); +use vars qw($fp $maxspots $defaultspots $maxdays $dirprefix %dup $duplth $dupage); $fp = undef; $maxspots = 50; # maximum spots to return $defaultspots = 10; # normal number of spots to return $maxdays = 35; # normal maximum no of days to go back $dirprefix = "spots"; +%dup = (); # the spot duplicates hash +$duplth = 20; # the length of text to use in the deduping +$dupage = 3*3600; # the length of time to hold spot dups sub init { @@ -41,14 +44,16 @@ sub add { my @spot = @_; # $freq, $call, $t, $comment, $spotter = @_ my @out = @spot[0..4]; # just up to the spotter - - # sure that the numeric things are numeric now (saves time later) - $spot[0] = 0 + $spot[0]; - $spot[2] = 0 + $spot[2]; + + # normalise frequency + $spot[0] = sprintf "%.f", $spot[0]; # remove ssids if present on spotter $out[4] =~ s/-\d+$//o; + # remove leading and trailing spaces + $spot[3] = unpad($spot[3]); + # add the 'dxcc' country on the end for both spotted and spotter, then the cluster call my @dxcc = Prefix::extract($out[1]); my $spotted_dxcc = (@dxcc > 0 ) ? $dxcc[1]->dxcc() : 0; @@ -194,4 +199,45 @@ sub readfile } return @spots; } + +# enter the spot for dup checking and return true if it is already a dup +sub dup +{ + my ($freq, $call, $d, $text) = @_; + + # dump if too old + return 2 if $d < $main::systime - $dupage; + + $freq = sprintf "%.1f", $freq; # normalise frequency + $d /= 60; # to the nearest minute + chomp $text; + $text = substr($text, 0, $duplth) if length $text > $duplth; + my $dupkey = "$freq|$call|$d|$text"; + return 1 if exists $dup{$dupkey}; + $dup{$dupkey} = $d * 60; # in seconds (to the nearest minute) + return 0; +} + +# called every hour and cleans out the dup cache +sub process +{ + my $cutoff = $main::systime - $dupage; + while (my ($key, $val) = each %dup) { + delete $dup{$key} if $val < $cutoff; + } +} + +sub listdups +{ + my @out; + for (sort { $dup{$a} <=> $dup{$b} } keys %dup) { + my $val = $dup{$_}; + push @out, "$_ = $val (" . cldatetime($val) . ")"; + } + return @out; +} 1; + + + + diff --git a/perl/client.pl b/perl/client.pl index 91d4add6..f59c5847 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -102,7 +102,7 @@ sub rec_socket cease(1); } if (defined $msg) { - my ($sort, $call, $line) = $msg =~ /^(\w)([A-Z0-9\-]+)\|(.*)$/; + my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; if ($sort eq 'D') { my $snl = $mynl; diff --git a/perl/cluster.pl b/perl/cluster.pl index d3ab1871..be8380c1 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -58,12 +58,14 @@ use Bands; use Geomag; use CmdAlias; use Filter; -use Local; use DXDb; -use Data::Dumper; +use AnnTalk; +use Data::Dumper; use Fcntl ':flock'; +use Local; + package main; @inqueue = (); # the main input queue, an array of hashes @@ -238,7 +240,7 @@ sub process_inqueue my $data = $self->{data}; my $dxchan = $self->{dxchan}; - my ($sort, $call, $line) = $data =~ /^(\w)([A-Z0-9\-]+)\|(.*)$/; + my ($sort, $call, $line) = $data =~ /^(\w)([^\|]+)\|(.*)$/; my $error; # the above regexp must work diff --git a/perl/console.pl b/perl/console.pl index bc3f3a9f..35e5da7e 100755 --- a/perl/console.pl +++ b/perl/console.pl @@ -214,7 +214,7 @@ sub rec_socket cease(1); } if (defined $msg) { - my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; + my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; if ($sort && $sort eq 'D') { addtotop($line); -- 2.43.0