From: Dirk Koopman Date: Sun, 28 Jun 2020 14:14:44 +0000 (+0100) Subject: Merge branch 'mojo' into users.v3j X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=commitdiff_plain;h=dd73f6f34ce7f3e142e480dfb7153611d87f509b;hp=fa27020ac9e6e3e8b64a2e82351eb00487b04bfb;p=spider.git Merge branch 'mojo' into users.v3j Also convert QSL.pm and create_qsl.pl to JSON format. --- diff --git a/Changes b/Changes index 4d546775..39cedc25 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,5 @@ +17Jun20======================================================================= +1. Change the Spot file reading mechanism back to the default of using 'tac'. 08Jun20======================================================================= 1. Fix show/mydx (lack of) filtering bug. 2. Add qra locator to prefix_data.pl. diff --git a/UPGRADE.mojo b/UPGRADE.mojo index c42313dc..502bb0e7 100644 --- a/UPGRADE.mojo +++ b/UPGRADE.mojo @@ -166,10 +166,6 @@ if you have not already done this: sudo ln -s /spider/perl/console.pl /usr/local/bin/dx sudo ln -s /spider/perl/*dbg /usr/local/bin -*IMPORTANT* (for any build of dxspider) regardless of branch below build 229 run: - - /spider/perl/convert-users-v3-to-v4.pl - Now in another window run: watchdbg diff --git a/cmd/accept/rbn.pl b/cmd/accept/rbn.pl new file mode 100644 index 00000000..69b39e6b --- /dev/null +++ b/cmd/accept/rbn.pl @@ -0,0 +1,14 @@ +# +# accept/reject filter commands +# +# Copyright (c) 2000 Dirk Koopman G1TLH +# +# +# + +my ($self, $line) = @_; +my $type = 'accept'; +my $sort = 'rbn'; + +my ($r, $filter, $fno) = $RBN::filterdef->cmd($self, $sort, $type, $line); +return (1, $r ? $filter : $self->msg('filter1', $fno, $filter->{name})); diff --git a/cmd/clear/rbn.pl b/cmd/clear/rbn.pl new file mode 100644 index 00000000..4a7222b8 --- /dev/null +++ b/cmd/clear/rbn.pl @@ -0,0 +1,38 @@ +# +# clear filters commands +# +# Copyright (c) 2000 Dirk Koopman G1TLH +# +# +# +my ($self, $line) = @_; +my @f = split /\s+/, $line; +my @out; +my $dxchan = $self; +my $sort = 'rbn'; +my $flag; +my $fno = 1; +my $call = $dxchan->call; +my $f; + +if ($self->priv >= 8) { + if (@f && is_callsign(uc $f[0])) { + $f = uc shift @f; + my $uref = DXUser::get($f); + $call = $uref->call if $uref; + } elsif (@f && lc $f[0] eq 'node_default' || lc $f[0] eq 'user_default') { + $call = lc shift @f; + } + if (@f && $f[0] eq 'input') { + shift @f; + $flag = 'in'; + } +} + +$fno = shift @f if @f && $f[0] =~ /^\d|all$/; + +my $filter = Filter::read_in($sort, $call, $flag); +Filter::delete($sort, $call, $flag, $fno); +$flag = $flag ? "input " : ""; +push @out, $self->msg('filter4', $flag, $sort, $fno, $call); +return (1, @out); diff --git a/cmd/links.pl b/cmd/links.pl index ab3f27a2..ed4082ff 100644 --- a/cmd/links.pl +++ b/cmd/links.pl @@ -28,7 +28,7 @@ foreach $dxchan ( sort {$a->call cmp $b->call} DXChannel::get_all ) { my $obscount = $dxchan->nopings; my $pingint = $dxchan->pingint; my $lastt = $dxchan->lastping ? ($dxchan->pingint - ($nowt - $dxchan->lastping)) : $pingint; - my $ping = $dxchan->is_node && $dxchan != $main::me ? sprintf("%7.2f",$dxchan->pingave) : ""; + my $ping = sprintf("%7.2f", $dxchan->pingave || 0); my $iso = $dxchan->isolate ? 'Y' : ' '; my $uptime = difft($dxchan->startt, 1); my ($fin, $fout, $pc92) = (' ', ' ', ' '); @@ -43,9 +43,10 @@ foreach $dxchan ( sort {$a->call cmp $b->call} DXChannel::get_all ) { $fout = $dxchan->routefilter =~ /node_default/ ? 'D' : 'Y'; } } - unless ($pingint) { + unless ($pingint && $ping) { $lastt = 0; - $ping = " "; + $ping = ' '; + $obscount = ' '; } $sort = "DXSP" if $dxchan->is_spider; diff --git a/cmd/reject/rbn.pl b/cmd/reject/rbn.pl new file mode 100644 index 00000000..de1ebd20 --- /dev/null +++ b/cmd/reject/rbn.pl @@ -0,0 +1,14 @@ +# +# accept/reject filter commands +# +# Copyright (c) 2000 Dirk Koopman G1TLH +# +# +# + +my ($self, $line) = @_; +my $type = 'reject'; +my $sort = 'rbn'; + +my ($r, $filter, $fno) = $RBN::filterdef->cmd($self, $sort, $type, $line); +return (0, $r ? $filter : $self->msg('filter1', $fno, $filter->{name})); diff --git a/cmd/set/rbn.pl b/cmd/set/rbn.pl new file mode 100644 index 00000000..2f1ff07a --- /dev/null +++ b/cmd/set/rbn.pl @@ -0,0 +1,59 @@ +# +# set user type to 'S' for Spider node +# +# Please note that this is only effective if the user is not on-line +# +# Copyright (c) 1998 - Dirk Koopman +# +# +# + +my ($self, $line) = @_; +my @args = split /\s+/, $line; +my $call; +my @out; +my $user; +my $create; + +return (1, $self->msg('e5')) if $self->priv < 5; + +foreach $call (@args) { + $call = uc $call; + if ($call eq $main::myalias) { + push @out, $self->msg('e11', $call); + next; + } + if ($call eq $main::myalias) { + push @out, $self->msg('e11', $call); + next; + } + my $chan = DXChannel::get($call); + if ($chan) { + push @out, $self->msg('nodee1', $call); + } else { + $user = DXUser::get($call); + $create = !$user; + $user = DXUser->new($call) if $create; + if ($user) { + $user->sort('N'); + $user->homenode($main::mycall); + $user->lockout(0); + $user->priv(0) unless $user->priv; + $user->close(); + push @out, $self->msg($create ? 'nodenc' : 'noden', $call); + } else { + push @out, $self->msg('e3', "Set RBN", $call); + } + } +} +return (1, @out); + + + + + + + + + + diff --git a/cmd/show/filter.pl b/cmd/show/filter.pl index f3aab016..ccfbc485 100644 --- a/cmd/show/filter.pl +++ b/cmd/show/filter.pl @@ -24,7 +24,7 @@ my @in; if (@f) { push @in, @f; } else { - push @in, qw(route ann spots wcy wwv); + push @in, qw(route ann spots wcy wwv rbn); } my $sort; diff --git a/cmd/show/prefix.pl b/cmd/show/prefix.pl index 1689d63a..0d46bb6a 100644 --- a/cmd/show/prefix.pl +++ b/cmd/show/prefix.pl @@ -20,12 +20,13 @@ foreach $l (@list) { my $pre = shift @ans; my $a; foreach $a (@ans) { - push @out, sprintf "%s DXCC: %d ITU: %d CQ: %d LL: %s %s (%s, %s)", uc $l, $a->dxcc, $a->itu, $a->cq, slat($a->lat), slong($a->long), $pre, $a->name; + push @out, substr(sprintf("%s CC: %d IZ: %d CZ: %d LL: %s %s %4.4s (%s, %s", uc $l, $a->dxcc, $a->itu, $a->cq, slat($a->lat), slong($a->long), $a->qra, $pre, $a->name), 0, 78) . ')'; $l = " " x length $l; } if ($USDB::present && $ans[0]->state) { push @out, sprintf "%s City: %s State: %s", $l, join (' ', map {ucfirst} split(/\s+/, lc $ans[0]->city)), $ans[0]->state; } + } return (1, @out); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 10466b0f..c35d21ca 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -80,12 +80,14 @@ $count = 0; wcyfilter => '5,WCY Filt-out', spotsfilter => '5,Spot Filt-out', routefilter => '5,Route Filt-out', + rbnfilter => '5,RBN Filt-out', pc92filter => '5,PC92 Route Filt-out', inannfilter => '5,Ann Filt-inp', inwwvfilter => '5,WWV Filt-inp', inwcyfilter => '5,WCY Filt-inp', inspotsfilter => '5,Spot Filt-inp', inroutefilter => '5,Route Filt-inp', + inrbnfilter => '5,RBN Filt-inp', inpc92filter => '5,PC92 Route Filt-inp', passwd => '9,Passwd List,yesno', pingint => '5,Ping Interval ', @@ -676,12 +678,7 @@ sub broadcast_list if ($sort eq 'dx') { next unless $dxchan->{dx}; - ($filter) = $dxchan->{spotsfilter}->it(@{$fref}) if ref $fref; - next unless $filter; - } - if ($sort eq 'rbn') { - next unless $dxchan->{dx}; # this is deliberate! - ($filter) = $dxchan->{spotsfilter}->it(@{$fref}) if ref $fref; + ($filter) = $dxchan->{spotsfilter}->it($fref) if $dxchan->{spotsfilter} && ref $fref; next unless $filter; } next if $sort eq 'ann' && !$dxchan->{ann} && $s !~ /^To\s+LOCAL\s+de\s+(?:$main::myalias|$main::mycall)/i; diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 900460ae..729675be 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -136,6 +136,7 @@ sub start $self->{dx} = $user->wantdx; $self->{logininfo} = $user->wantlogininfo; $self->{ann_talk} = $user->wantann_talk; + $self->{wantrbn} = $user->wantrbn; $self->{here} = 1; $self->{prompt} = $user->prompt if $user->prompt; $self->{lastmsgpoll} = 0; @@ -176,7 +177,10 @@ sub start $self->{annfilter} = Filter::read_in('ann', $call, 0) || Filter::read_in('ann', $nossid, 0) || Filter::read_in('ann', 'user_default', 0) ; - + $self->{rbnfilter} = Filter::read_in('rbn', $call, 0) + || Filter::read_in('rbn', $nossid, 0) + || Filter::read_in('rbn', 'user_default', 0); + # clean up qra locators my $qra = $user->qra; $qra = undef if ($qra && !DXBearing::is_qra($qra)); diff --git a/perl/DXUser.pm b/perl/DXUser.pm index f78c8120..1249b0b6 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -20,6 +20,7 @@ use File::Copy; use Data::Structure::Util qw(unbless); use Time::HiRes qw(gettimeofday tv_interval); use IO::File; +use JSON; use strict; @@ -106,6 +107,7 @@ my $json; maxconnect => '1,Max Connections', startt => '0,Start Time,cldatetime', connlist => '1,Connections,parraydifft', + width => '0,Preferred Width' ); #no strict; @@ -487,10 +489,10 @@ print "There are $count user records and $err errors in $diff mS\n"; 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: invalid callsign($ekey) => '$eval'"); + $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; + LogDbg('DXCommand', "Export Error1: invalid call '$key' => '$val'"); eval {$dbm->del($key)}; - dbg(carp("Export Error1: delete call $ekey => '$eval' $@")) if $@; + dbg(carp("Export Error1: delete $key => '$val' $@")) if $@; ++$err; next; } @@ -501,7 +503,7 @@ print "There are $count user records and $err errors in $diff mS\n"; if ($ref->is_user && !$ref->{priv} && $main::systime > $t + $tooold) { unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) { eval {$dbm->del($key)}; - dbg(carp("Export Error2: delete $key => '$val' $@")) if $@; + dbg(carp("Export Error2: delete '$key' => '$val' $@")) if $@; LogDbg('DXCommand', "$ref->{call} deleted, too old"); $del++; next; @@ -511,9 +513,9 @@ print "There are $count user records and $err errors in $diff mS\n"; print $fh "$key\t" . encode($ref) . "\n"; ++$count; } else { - LogDbg('DXCommand', "Export Error3: $key\t" . carp($val) ."\n$@"); + LogDbg('DXCommand', "Export Error3: '$key'\t" . carp($val) ."\n$@"); eval {$dbm->del($key)}; - dbg(carp("Export Error3: $key\t$val\n$@")) if $@; + dbg(carp("Export Error3: delete '$key' => '$val' $@")) if $@; ++$err; } } diff --git a/perl/Filter.pm b/perl/Filter.pm index 12caeef3..867c8ddf 100644 --- a/perl/Filter.pm +++ b/perl/Filter.pm @@ -231,13 +231,15 @@ sub it my $hops = $self->{hops} if exists $self->{hops}; if (isdbg('filter')) { + my $call = $self->{name}; my $args = join '\',\'', map {defined $_ ? $_ : 'undef'} (ref $_[0] ? @{$_[0]} : @_); my $true = $r ? "OK " : "REJ"; my $sort = $self->{sort}; my $dir = $self->{name} =~ /^in_/i ? "IN " : "OUT"; - + + $call =~ s/\.PL$//i; my $h = $hops || ''; - dbg("$true $dir: $type/$sort with $asc on '$args' $h") if isdbg('filter'); + dbg("Filter: $call $true $dir: $type/$sort with '$asc' on '$args' $h") if isdbg('filter'); } return ($r, $hops); } @@ -581,7 +583,8 @@ sub cmd $r = $filter->write; return (1,$r) if $r; - + + $filter->install(1); # 'delete' $filter->install; return (0, $filter, $fno); diff --git a/perl/QSL.pm b/perl/QSL.pm index 0df7570b..e303e123 100644 --- a/perl/QSL.pm +++ b/perl/QSL.pm @@ -8,37 +8,33 @@ package QSL; use strict; -use DXVars; +use SysVar; use DXUtil; use DB_File; use DXDebug; use Prefix; +use JSON; +use Data::Structure::Util qw(unbless); use vars qw($qslfn $dbm $maxentries); -$qslfn = 'qsl'; +$qslfn = 'dxqsl'; $dbm = undef; $maxentries = 50; -localdata_mv("$qslfn.v1"); +my $json; + +localdata_mv("$qslfn.v1j"); sub init { my $mode = shift; - my $ufn = localdata("$qslfn.v1"); + my $ufn = localdata("$qslfn.v1j"); - Prefix::load() unless Prefix::loaded(); + $json = JSON->new->canonical(1); - eval { - require Storable; - }; + Prefix::load() unless Prefix::loaded(); - if ($@) { - dbg("Storable appears to be missing"); - dbg("In order to use the QSL feature you must"); - dbg("load Storable from CPAN"); - return undef; - } - import Storable qw(nfreeze freeze thaw); + my %u; undef $dbm; if ($mode) { @@ -119,7 +115,7 @@ sub get my $r = $dbm->get($key, $value); return undef if $r; - return thaw($value); + return decode($value); } sub put @@ -127,8 +123,40 @@ sub put return unless $dbm; my $self = shift; my $key = $self->[0]; - my $value = nfreeze($self); + my $value = encode($self); $dbm->put($key, $value); } +sub remove_files +{ + unlink "$main::data/qsl.v1j"; + unlink "$main::local_data/qsl.v1j"; +} + +# thaw the user +sub decode +{ + my $s = shift; + my $ref; + eval { $ref = $json->decode($s) }; + if ($ref && !$@) { + return bless $ref, 'QSL'; + } + return undef; +} + +# freeze the user +sub encode +{ + my $ref = shift; + unbless($ref); + my $s; + + eval {$s = $json->encode($ref) }; + if ($s && !$@) { + bless $ref, 'QSL'; + return $s; + } +} + 1; diff --git a/perl/RBN.pm b/perl/RBN.pm index ba81f735..6773118f 100644 --- a/perl/RBN.pm +++ b/perl/RBN.pm @@ -18,37 +18,26 @@ use DXUser; use DXChannel; use Math::Round qw(nearest); use Date::Parse; +use Time::HiRes qw(clock_gettime CLOCK_REALTIME); +use Spot; our @ISA = qw(DXChannel); -our $startup_delay =3*60; # don't send anything out until this timer has expired +our $startup_delay = 5*60; # don't send anything out until this timer has expired # this is to allow the feed to "warm up" with duplicates - # so that the "big rush" doesn't happen. + # so that the "big rush" doesn't happen. our $minspottime = 60*60; # the time between respots of a callsign - if a call is # still being spotted (on the same freq) and it has been # spotted before, it's spotted again after this time # until the next minspottime has passed. -our %hfitu = ( - 1 => [1, 2,], - 2 => [1, 2, 3,], - 3 => [2,3, 4,], - 4 => [3,4, 9,], -# 5 => [0], - 6 => [7], - 7 => [7, 6, 8, 10], - 8 => [7, 8, 9], - 9 => [8, 9], - 10 => [10], - 11 => [11], - 12 => [12, 13], - 13 => [12, 13], - 14 => [14, 15], - 15 => [15, 14], - 16 => [16], - 17 => [17], - ); +our $beacontime = 5*60; # same as minspottime, but for beacons (and shorter) + +our $dwelltime = 6; # the amount of time to wait for duplicates before issuing + # a spot to the user (no doubt waiting with bated breath). + +our $filterdef = $Spot::filterdef; # we use the same filter as the Spot system. Can't think why :-). sub new { @@ -58,8 +47,7 @@ sub new my $pkg = shift; my $call = shift; - DXProt::_add_thingy($main::routeroot, [$call, 0, 0, 1, undef, undef, $self->hostname], ); - $self->{d} = {}; +# DXProt::_add_thingy($main::routeroot, [$call, 0, 0, 1, undef, undef, $self->hostname], ); $self->{spot} = {}; $self->{last} = 0; $self->{noraw} = 0; @@ -68,7 +56,10 @@ sub new $self->{sort} = 'N'; $self->{lasttime} = $main::systime; $self->{minspottime} = $minspottime; + $self->{beacontime} = $beacontime; $self->{showstats} = 0; + $self->{pingint} = 0; + $self->{nopings} = 0; return $self; } @@ -79,8 +70,6 @@ sub start my $user = $self->{user}; my $call = $self->{call}; my $name = $user->{name}; - my $dref = $self->{d}; - my $spotref = $self->{spot}; # log it my $host = $self->{conn}->peerhost; @@ -97,7 +86,10 @@ sub start ($h) = $line =~ /host=([\da..fA..F:]+)/; $line =~ s/\s*host=[\da..fA..F:]+// if $h; } - $self->{hostname} = $h if $h; + if ($h) { + $h =~ s/^::ffff://; + $self->{hostname} = $h; + } } $self->{width} = 80 unless $self->{width} && $self->{width} > 80; $self->{consort} = $line; # save the connection type @@ -112,11 +104,10 @@ sub start # get the filters my $nossid = $call; $nossid =~ s/-\d+$//; - - $self->{spotsfilter} = Filter::read_in('spots', $call, 0) - || Filter::read_in('spots', $nossid, 0) - || Filter::read_in('spots', 'user_default', 0); + $self->{inrbnfilter} = Filter::read_in('rbn', $call, 1) + || Filter::read_in('rbn', 'node_default', 1); + # clean up qra locators my $qra = $user->qra; $qra = undef if ($qra && !DXBearing::is_qra($qra)); @@ -130,13 +121,14 @@ sub start $self->{inrushpreventor} = $main::systime + $startup_delay; } +my @queue; # the queue of spots ready to send + sub normal { my $self = shift; my $line = shift; my @ans; - my $d = $self->{d}; - my $spot = $self->{spot}; + my $spots = $self->{spot}; # save this for them's that need it my $rawline = $line; @@ -186,26 +178,21 @@ sub normal } } if ($sort && $sort eq 'NCDXF') { - $mode = $sort; + $mode = 'DXF'; $t = $tx; } if ($sort && $sort eq 'BEACON') { - $mode = 'BECON'; + $mode = 'BCN'; + } + if ($mode =~ /^PSK/) { + $mode = 'PSK'; + } + if ($mode eq 'RTTY') { + $mode = 'RTT'; } - - # We have an RBN data line, dedupe it very simply on time, ignore QRG completely. - # This works because the skimmers are NTP controlled (or should be) and will receive - # the spot at the same time (velocity factor of the atmosphere and network delays - # carefully (not) taken into account :-) - - # Note, there is no intelligence here, but there are clearly basic heuristics that could - # be applied at this point that reject (more likely rewrite) the call of a busted spot that would - # useful for a zonal hotspot requirement from the cluster node. - # In reality, this mechanism would be incorporated within the cluster code, utilising the dxqsl database, - # and other resources in DXSpider, thus creating a zone map for an emitted spot. This is then passed through the - # normal "to-user" spot system (where normal spots are sent to be displayed per user) and then be - # processed through the normal, per user, spot filtering system - like a regular spot. + # The main de-duping key is [call, $frequency], but we probe a bit around that frequency to find a + # range of concurrent frequencies that might be in play. # The key to this is deducing the true callsign by "majority voting" (the greater the number of spotters # the more effective this is) together with some lexical analsys probably in conjuction with DXSpider @@ -221,97 +208,147 @@ sub normal # Clearly this will only work in the 'mojo' branch of DXSpider where it is possible to pass off external # data requests to ephemeral or semi resident forked processes that do any grunt work and the main # process to just the standard "message passing" which has been shown to be able to sustain over 5000 - # per second (limited by the test program's output and network speed, rather than DXSpider's handling). - - my $p = "$t|$call"; - ++$self->{noraw}; - return if $d->{$p}; - - # new RBN input - $d->{$p} = $tim; - ++$self->{norbn}; - $qrg = sprintf('%.1f', nearest(.1, $qrg)); # to nearest 100Hz (to catch the odd multiple decpl QRG [eg '7002.07']). - if (isdbg('rbnraw')) { - my $ss = join(',', "RBN", $origin, $qrg, $call, $mode, $s, $m, $spd, $u, $sort, $t); - $ss .= ",$b" if $b; - dbg "RBNRAW:$ss"; - } + # per second (limited by the test program's output and network speed, rather than DXSpider's handling). - # Determine whether to "SPOT" it based on whether we have not seen it before (near this QRG) or, - # if we have, has it been a "while" since the last time we spotted it? If it has been spotted - # before then "RESPOT" it. my $nqrg = nearest(1, $qrg); # normalised to nearest Khz - my $sp = "$call|$nqrg"; # hopefully the skimmers will be calibrated at least this well! - my $ts = $spot->{$sp}; - - if (!$ts || ($self->{minspottime} > 0 && $tim - $ts >= $self->{minspottime})) { - ++$self->{nospot}; - my $tag = $ts ? "RESPOT" : "SPOT"; - $t .= ",$b" if $b; + 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! + + # do we have it? + my $spot = $spots->{$sp}; + $spot = $spots->{$spp}, $sp = $spp, dbg(qq{RBN: SPP using $spp for $sp}) if !$spot && exists $spots->{$spp}; + $spot = $spots->{$spm}, $sp = $spm, dbg(qq{RBN: SPM using $spm for $sp}) if !$spot && exists $spots->{$spm}; + - my ($hh,$mm) = $t =~ /(\d\d)(\d\d)Z$/; - my $utz = str2time(sprintf('%02d:%02dZ', $hh, $mm)); - dbg "RBN:" . join(',', $tag, $origin, $qrg, $call, $mode, $s, $m, $spd, $u, $sort, $t) if dbg('rbn'); + # if we have one and there is only one slot and that slot's time isn't expired for respot then return + my $respot = 0; + if ($spot && ref $spot) { + if (@$spot == 1) { + unless ($self->{minspottime} > 0 && $tim - $spot->[0] >= $self->{minspottime}) { + dbg("RBN: key: '$sp' call: $call qrg: $qrg DUPE \@ ". atime(int $spot->[0])) if isdbg('rbn'); + return; + } + + dbg("RBN: key: '$sp' RESPOTTING call: $call qrg: $qrg last seen \@ ". atime(int $spot->[0])) if isdbg('rbn'); + undef $spot; # it's about to be recreated (in one place) + ++$respot; + } + # otherwise we have a spot being built up at the moment + } elsif ($spot) { + dbg("RBN: key '$sp' = '$spot' not ref"); + return; + } - my @s = Spot::prepare($qrg, $call, $utz, sprintf("%-5s%3d $m", $mode, $s), $origin); + # 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)];; + dbg("RBN: key: '$sp' call: $call qrg: $qrg NEW" . $respot ? ' RESPOT' : '') if isdbg('rbn'); + } - if (isdbg('progress')) { - my $d = ztime($s[2]); - my $s = "RBN: $s[1] on $s[0] \@ $d by $s[4]"; - $s .= $s[3] ? " '$s[3]'" : q{ ''}; - $s .= " route: $self->{call}"; - dbg($s); + # add me to the display queue unless we are waiting for initial in rush to finish + return unless $self->{inrushpreventor} < $main::systime; + push @{$self->{queue}}, $sp if @$spot == 1; # queue the KEY (not the record) + + # build up a new record and store it in the buildup + # deal with the unix time + my ($hh,$mm) = $t =~ /(\d\d)(\d\d)Z$/; + my $utz = $hh*3600 + $mm*60 + $main::systime_daystart; # possible issue with late spot from previous day + $utz -= 86400 if $utz > $tim+3600; # too far ahead, drag it back one day + + # create record and add into the buildup + my $r = [$origin, nearest(.1, $qrg), $call, $mode, $s, $t, $utz, $respot, $u]; + dbg("RBN: key: '$sp' ADD RECORD call: $call qrg: $qrg origin: $origin") if isdbg('rbn'); + my @s = Spot::prepare($r->[1], $r->[2], $r->[6], '', $r->[0]); + if ($self->{inrbnfilter}) { + my ($want, undef) = $self->{inrbnfilter}->it($s); + next unless $want; + } + $r->[9] = \@s; + + 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); + + # now run the waiting queue which just contains KEYS ($call|$qrg) + foreach $sp (@{$self->{queue}}) { + my $cand = $spots->{$sp}; + unless ($cand && $cand->[0]) { + dbg "RBN Cand " . ($cand ? 'def' : 'undef') . " [0] " . ($cand->[0] ? 'def' : 'undef') . " dwell $dwelltime"; + next; + } + if ($now >= $cand->[0] + $dwelltime ) { + # we have a candidate, create qualitee value(s); + unless (@$cand > 1) { + dbg "RBN: QUEUE key '$sp' MISSING RECORDS " . dd($cand) if isdbg 'rbn'; + shift @{$self->{queue}}; + next; + } + my $savedtime = shift @$cand; # save the start time + my $r = $cand->[0]; + my $quality = @$cand; + $quality = 9 if $quality > 9; + $quality = "Q:$quality"; + if (isdbg('progress')) { + my $s = "RBN: SPOT key: '$sp' = $r->[2] on $r->[1] \@ $r->[5] $quality"; + $s .= " route: $self->{call}"; + dbg($s); + } + + send_dx_spot($self, $quality, $cand); + + # clear out the data and make this now just "spotted", but no further action required until respot time + dbg "RBN: QUEUE key '$sp' cleared" if isdbg 'rbn'; + + $spots->{$sp} = [$savedtime]; + shift @{$self->{queue}}; + } else { + dbg sprintf("RBN: QUEUE key: '$sp' SEND time not yet reached %.1f secs left", $spot->[0] + $dwelltime - $now) if isdbg 'rbnqueue'; } - - send_dx_spot($self, $line, $mode, \@s) unless $self->{inrushpreventor} > $main::systime; - - $spot->{$sp} = $tim; } + + } else { dbg "RBN:DATA,$line" if isdbg('rbn'); } - # periodic clearing out of the two caches + # # periodic clearing out of the two caches if (($tim % 60 == 0 && $tim > $self->{last}) || ($self->{last} && $tim >= $self->{last} + 60)) { my $count = 0; my $removed = 0; - - while (my ($k,$v) = each %{$d}) { - if ($tim-$v > 60) { - delete $d->{$k}; - ++$removed - } else { - ++$count; - } - } - dbg "RBN:ADMIN,rbn cache: $removed removed $count remain" if isdbg('rbn'); - $count = $removed = 0; - while (my ($k,$v) = each %{$spot}) { - if ($tim-$v > $self->{minspottime}*2) { - delete $spot->{$k}; + while (my ($k,$v) = each %{$spots}) { + if ($tim - $v->[0] > $self->{minspottime}*2) { + delete $spots->{$k}; ++$removed; - } else { + } + else { ++$count; } } - dbg "RBN:ADMIN,spot cache: $removed removed $count remain" if isdbg('rbn'); - + dbg "RBN:ADMIN,$self->{call},spot cache remain: $count removed: $removed"; # if isdbg('rbn'); dbg "RBN:" . join(',', "STAT", $self->{noraw}, $self->{norbn}, $self->{nospot}) if $self->{showstats}; $self->{noraw} = $self->{norbn} = $self->{nospot} = 0; - $self->{last} = int($tim / 60) * 60; } } -# we only send to users and we send the original line (possibly with a -# Q:n in it) + + +# } +# } + +# we should get the spot record minus the time, so just an array of record (arrays) sub send_dx_spot { my $self = shift; - my $line = shift; - my $mode = shift; - my $sref = shift; + my $quality = shift; + my $spot = shift; + + # $r = [$origin, $qrg, $call, $mode, $s, $utz, $respot]; + + my $mode = $spot->[0]->[3]; # as all the modes will be the same; my @dxchan = DXChannel::get_all(); @@ -320,18 +357,20 @@ sub send_dx_spot my $user = $dxchan->{user}; next unless $user && $user->wantrbn; + # does this user want this sort of spot at all? my $want = 0; - ++$want if $user->wantbeacon && $mode =~ /^BEA|NCD/; + ++$want if $user->wantbeacon && $mode =~ /^BCN|DXF/; ++$want if $user->wantcw && $mode =~ /^CW/; - ++$want if $user->wantrtty && $mode =~ /^RTTY/; + ++$want if $user->wantrtty && $mode =~ /^RTT/; ++$want if $user->wantpsk && $mode =~ /^PSK/; ++$want if $user->wantcw && $mode =~ /^CW/; ++$want if $user->wantft && $mode =~ /^FT/; - ++$want unless $want; # send everything if nothing is selected. - - $self->dx_spot($dxchan, $sref) if $want; + next unless $want; + + # send one spot to one user out of the ones that we have + $self->dx_spot($dxchan, $quality, $spot) if $want; } } @@ -339,51 +378,91 @@ sub dx_spot { my $self = shift; my $dxchan = shift; - my $sref = shift; - -# return unless $dxchan->{rbn}; + my $quality = shift; + my $spot = shift; - my ($filter, $hops); + my $strength = 100; # because it could if we talk about FTx + my $saver; - if ($dxchan->{rbnfilter}) { - ($filter, $hops) = $dxchan->{rbnfilter}->it($sref); - return unless $filter; - } elsif ($self->{rbnfilter}) { - ($filter, $hops) = $self->{rbnfilter}->it($sref); - return unless $filter; - } + my %zone; + my %qrg; + my $respot; + my $qra; + + foreach my $r (@$spot) { + # $r = [$origin, $qrg, $call, $mode, $s, $t, $utz, $respot, $qra]; + # Spot::prepare($qrg, $call, $utz, $comment, $origin); -# dbg('RBN::dx_spot spot: "' . join('","', @$sref) . '"') if isdbg('rbn'); + 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 $buf; - if ($self->{ve7cc}) { - $buf = VE7CC::dx_spot($dxchan, @$sref); - } else { - $buf = $self->format_dx_spot(@$sref); - $buf =~ s/\%5E/^/g; - } - $dxchan->local_send('N', $buf); -} + my $s = $r->[9]; # the prepared spot + $s->[3] = $comment; # apply new generated comment + + + ++$zone{$s->[11]}; # save the spotter's zone + ++$qrg{$s->[0]}; # and the qrg -sub format_dx_spot -{ - my $self = shift; + + my $want = 0; + my $rf = $dxchan->{rbnfilter} || $dxchan->{spotsfilter}; + if ($rf) { + ($want, undef) = $rf->it($s); + next unless $want; + $saver = $s; + dbg("RBN: FILTERED call: $s->[1] qrg: $s->[0] origin: $s->[4] dB: $r->[4]") if isdbg 'rbn'; + last; + } - my $t = ztime($_[2]); - my $clth = $self->{consort} eq 'local' ? 29 : 30; - my $comment = $_[3] || ''; - my $loc = ''; - my $ref = DXUser::get_current($_[1]); - if ($ref && $ref->qra) { - $loc = ' ' . substr($ref->qra, 0, 4); + # 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'; + } } - $comment .= ' ' x ($clth - (length($comment)+length($loc)+1)); - $comment .= $loc; - $loc = ''; - my $ref = DXUser::get_current($_[4]); - if ($ref && $ref->qra) { - $loc = ' ' . substr($ref->qra, 0, 4); + + if ($saver) { + my $buf; + # create a zone list of spotters + delete $zone{$saver->[11]}; # 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 + my $mv = 0; + my $fk; + my $c = 0; + while (my ($k, $v) = each %qrg) { + $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; + + dbg("RBN: SENDING call: $saver->[1] qrg: $saver->[0] origin: $saver->[4] $saver->[3]") if isdbg 'rbn'; + if ($dxchan->{ve7cc}) { + my $call = $saver->[4]; + $saver->[4] .= '-#'; + $buf = VE7CC::dx_spot($dxchan, @$saver); + $saver->[4] = $call; + } else { + $buf = $dxchan->format_dx_spot(@$saver); + } + $buf =~ s/^DX/RB/; + $dxchan->local_send('N', $buf); + + if ($qra) { + my $user = DXUser::get_current($saver->[1]) || DXUser->new($saver->[1]); + unless ($user->qra && is_qra($user->qra)) { + $user->qra($qra); + dbg("RBN: update qra on $saver->[1] to $qra"); + $user->put; + } + } } - return sprintf "RB de %-7.7s%11.1f %-12.12s %-s $t$loc", "$_[4]:", $_[0], $_[1], $comment; } + 1; diff --git a/perl/Spot.pm b/perl/Spot.pm index 8b703306..be175ff0 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -63,7 +63,7 @@ $filterdef = bless ([ $totalspots = $hfspots = $vhfspots = 0; $use_db_for_search = 0; -our $readback = 0; +our $readback = 1; if ($readback) { $readback = `which tac`; diff --git a/perl/create_qsl.pl b/perl/create_qsl.pl index f4083f55..38fccc5a 100755 --- a/perl/create_qsl.pl +++ b/perl/create_qsl.pl @@ -32,13 +32,11 @@ use vars qw($end $lastyear $lastday $lasttime); $end = 0; $SIG{TERM} = $SIG{INT} = sub { $end++ }; -my $qslfn = "qsl"; +my $qslfn = "dxqsl"; $main::systime = time; -unlink "$data/qsl.v1"; -unlink "$local_data/qsl.v1"; - +QSL::remove_files(); QSL::init(1) or die "cannot open QSL file"; my $base = localdata("spots");