From d40358b98c4f3fe24890369543dd7768c99da962 Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Thu, 28 May 2020 00:35:42 +0100 Subject: [PATCH] RBN now with basic spots --- cmd/set/wantrbn.pl | 27 +++++++++++++++++++++ cmd/show/debug_ring.pl | 1 - cmd/unset/wantrbn.pl | 27 +++++++++++++++++++++ perl/DXChannel.pm | 3 --- perl/DXCommandmode.pm | 3 --- perl/DXProt.pm | 5 ++++ perl/DXUser.pm | 7 ++++-- perl/DXUtil.pm | 8 ++++++- perl/Messages | 2 ++ perl/Msg.pm | 5 ++-- perl/RBN.pm | 53 +++++++++++++++++++++++++++++++++++++----- perl/cluster.pl | 8 +++---- 12 files changed, 126 insertions(+), 23 deletions(-) create mode 100644 cmd/set/wantrbn.pl create mode 100644 cmd/unset/wantrbn.pl diff --git a/cmd/set/wantrbn.pl b/cmd/set/wantrbn.pl new file mode 100644 index 00000000..f4aa86e2 --- /dev/null +++ b/cmd/set/wantrbn.pl @@ -0,0 +1,27 @@ +# +# set the want rbn (at all) +# +# Copyright (c) 2020 - Dirk Koopman +# +# +# + +my ($self, $line) = @_; +my @args = split /\s+/, $line; +my $call; +my @out; + +@args = $self->call if (!@args || $self->priv < 9); + +foreach $call (@args) { + $call = uc $call; + my $user = DXUser::get_current($call); + if ($user) { + $user->wantrbn(1); + $user->put; + push @out, $self->msg('wante', 'RBN', $call); + } else { + push @out, $self->msg('e3', "Set wantrbn", $call); + } +} +return (1, @out); diff --git a/cmd/show/debug_ring.pl b/cmd/show/debug_ring.pl index 9513b965..a8a2900e 100644 --- a/cmd/show/debug_ring.pl +++ b/cmd/show/debug_ring.pl @@ -18,6 +18,5 @@ for (@args) { } my $lines = DXDebug::dbgprintring($n); DXDebug::dbgclearring() if $doclear; -dge; return (1, qq{Contents of $lines lines of debug ring buffer logged. View with watchdbg.}); diff --git a/cmd/unset/wantrbn.pl b/cmd/unset/wantrbn.pl new file mode 100644 index 00000000..33a2dccf --- /dev/null +++ b/cmd/unset/wantrbn.pl @@ -0,0 +1,27 @@ +# +# set the want rbn (at all) +# +# Copyright (c) 2020 - Dirk Koopman +# +# +# + +my ($self, $line) = @_; +my @args = split /\s+/, $line; +my $call; +my @out; + +@args = $self->call if (!@args || $self->priv < 9); + +foreach $call (@args) { + $call = uc $call; + my $user = DXUser::get_current($call); + if ($user) { + $user->wantrbn(0); + $user->put; + push @out, $self->msg('wantd', 'RBN', $call); + } else { + push @out, $self->msg('e3', "Unset wantrbn", $call); + } +} +return (1, @out); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 73102ff4..10466b0f 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -62,9 +62,6 @@ $count = 0; here => '0,Here?,yesno', conf => '0,In Conference?,yesno', dx => '0,DX Spots,yesno', - rbn => '0,RBN Spots,yesno', - ft => '0,(RBN) FT4/8 Spots,yesno', - cw => '0,RBN CW Spots,yesno', redirect => '0,Redirect messages to', lang => '0,Language', func => '5,Function', diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index a75bf157..8bb6659e 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -139,9 +139,6 @@ sub start $self->{here} = 1; $self->{prompt} = $user->prompt if $user->prompt; $self->{lastmsgpoll} = 0; - $self->{rbn} = $user->wantrbn; - $self->{ft} = $user->wantft; - $self->{cw} = $user->wantcw; # sort out new dx spot stuff $user->wantdxcq(0) unless defined $user->{wantdxcq}; diff --git a/perl/DXProt.pm b/perl/DXProt.pm index aae3cc77..b5606eff 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -561,6 +561,7 @@ sub send_dx_spot foreach $dxchan (@dxchan) { next if $dxchan == $main::me; next if $dxchan == $self && $self->is_node; + next if $dxchan->is_rbn; if ($line =~ /PC61/ && !($dxchan->is_spider || $dxchan->is_user)) { unless ($pc11) { my @f = split /\^/, $line; @@ -621,6 +622,7 @@ sub send_wwv_spot foreach $dxchan (@dxchan) { next if $dxchan == $main::me; next if $dxchan == $self && $self->is_node; + next if $dxchan->is_rbn; my $routeit; my ($filter, $hops); @@ -655,6 +657,7 @@ sub send_wcy_spot foreach $dxchan (@dxchan) { next if $dxchan == $main::me; next if $dxchan == $self; + next if $dxchan->is_rbn; $dxchan->wcy($line, $self->{isolate}, @_, $self->{call}, @dxcc); } @@ -738,6 +741,7 @@ sub send_announce next if $dxchan == $self && $self->is_node; next if $from_pc9x && $dxchan->{do_pc9x}; next if $target eq 'LOCAL' && $dxchan->is_node; + next if $dxchan->is_rbn; $dxchan->announce($line, $self->{isolate}, $to, $target, $text, @_, $self->{call}, @a[0..2], @b[0..2]); } @@ -810,6 +814,7 @@ sub send_chat next unless $dxchan->is_spider && $dxchan->do_pc9x; next if $target eq 'LOCAL'; } + next if $dxchan->is_rbn; $dxchan->chat($line, $self->{isolate}, $target, $_[1], $text, @_, $self->{call}, @a[0..2], @b[0..2]); diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 1fc8dd86..b33f8823 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -84,8 +84,11 @@ our $maxconnlist = 3; # remember this many connection time (duration) [start, wantgtk => '0,Want GTK interface,yesno', wantpc9x => '0,Want PC9X interface,yesno', wantrbn => '0,Want RBN spots,yesno', - wantft => '0,Want FT4/8 spots,yesno', - wantcw => '0,Want (RBN) CW spots,yesno', + wantft => '0,Want RBN FT4/8,yesno', + wantcw => '0,Want RBN CW,yesno', + wantrtty => '0,Want RBN RTTY,yesno', + wantpsk => '0,Want RBN PSK,yesno', + wantbeacon => '0,Want (RBN) Beacon,yesno', lastoper => '9,Last for/oper,cldatetime', nothere => '0,Not Here Text', registered => '9,Registered?,yesno', diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 91c63691..e77eb294 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -27,7 +27,7 @@ require Exporter; print_all_fields cltounix unpad is_callsign is_latlong is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem is_prefix dd is_ipaddr $pi $d2r $r2d localdata localdata_mv - diffms _diffms difft parraydifft + diffms _diffms difft parraydifft is_ztime ); @@ -444,6 +444,12 @@ sub is_ipaddr return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~ /^[0-9a-f:,]+$/; } +# is it a zulu time hhmmZ +sub is_ztime +{ + return $_[0] =~ /^(?:(?:2[0-3])|(?:[01][0-9]))[0-5][0-9]Z$/; +} + # insert an item into a list if it isn't already there returns 1 if there 0 if not sub insertitem { diff --git a/perl/Messages b/perl/Messages index 96167a7e..4efde147 100644 --- a/perl/Messages +++ b/perl/Messages @@ -342,6 +342,8 @@ package DXM; usernf => '*** User record for $_[0] not found ***', usstates => 'US State display enabled for $_[0]', usstateu => 'US State display disabled for $_[0]', + wante => 'Want $_[0] enabled for $_[1]', + wantd => 'Want $_[0] disabled for $_[1]', wcy1 => '$_[0] is missing or out of range', wcy2 => 'Duplicate WCY', wcy3 => 'Date Hour SFI A K Exp.K R SA GMF Aurora Logger', diff --git a/perl/Msg.pm b/perl/Msg.pm index 9b7ce76f..81c2e40a 100644 --- a/perl/Msg.pm +++ b/perl/Msg.pm @@ -257,7 +257,7 @@ sub disconnect my ($pkg, $fn, $line) = caller if $dbg; if ($count >= 2) { - dbg((ref $conn) . "::disconnect on call $conn->{call} attempt $conn->{disconnecting} called from ${pkg}::${fn} line $line FORCING CLOSE ") if $dbg; + dbgtrace((ref $conn) . "::disconnect on call $conn->{call} attempt $conn->{disconnecting} called from ${pkg}::${fn} line $line FORCING CLOSE ") if $dbg; _close_it($conn); return; } @@ -553,8 +553,7 @@ sub DESTROY if (isdbg('connll')) { my ($pkg, $fn, $line) = caller; - dbg((ref $conn) . "::DESTROY on call $call called from ${pkg}::${fn} line $line "); - + dbgtrace((ref $conn) . "::DESTROY on call $call called from ${pkg}::${fn} line $line "); } my $call = $conn->{call} || 'unallocated'; diff --git a/perl/RBN.pm b/perl/RBN.pm index b6c0fef0..9687b18f 100644 --- a/perl/RBN.pm +++ b/perl/RBN.pm @@ -120,17 +120,27 @@ sub normal # parse line dbg "RBN:RAW,$line" if isdbg('rbnraw'); - my ($origin, $qrg, $call, $mode, $s, $m, $spd, $u, $sort, $t, $tx) = split /[:\s]+/, $line; - $tx ||= ''; - dbg qq{0:$origin 1:$qrg 2:$call 3:$mode 4:$s 5:m 6:$spd 7:$u 8:$sort 9:$t 10:$tx} if $line =~ /DX/; + my (undef, undef, $origin, $qrg, $call, $mode, $s, $m, $spd, $u, $sort, $t, $tx) = split /[:\s]+/, $line; + # fix up FT8 spots from 7001 + $t = $u, $u = '' if !$t && is_ztime($u); + $t = $sort, $sort = '' if !$t && is_ztime($sort); + my $qra = $spd, $spd = '' if is_qra($spd); + $u = $qra if $qra; + +# no warnings qw(uninitialized); + +# dbg qq{or:$origin qr:$qrg ca:$call mo:$mode s:$s m:$m sp:$spd u:$u sort:$sort t:$t tx:$tx qra:$qra} if $line =~ /DX/; + +# use warnings; + my $b; if ($t || $tx) { # fix up times for things like 'NXDXF B' etc - if ($tx && $t !~ /^\d{4}Z$/) { - if ($tx =~ /^\d{4}Z$/) { + if ($tx && is_ztime($t)) { + if (is_ztime($tx)) { $b = $t; $t = $tx; } else { @@ -138,7 +148,7 @@ sub normal return (0); } } - + # 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 @@ -194,7 +204,11 @@ sub normal ++$self->{nospot}; my $tag = $ts ? "RESPOT" : "SPOT"; $t .= ",$b" if $b; + $sort ||= ''; dbg "RBN:" . join(',', $tag, $origin, $qrg, $call, $mode, $s, $m, $spd, $u, $sort, $t); + + send_dx_spot($self, $line, $mode); + $spot->{$sp} = $tim; } } else { @@ -233,7 +247,34 @@ sub normal } } +# we only send to users and we send the original line (possibly with a +# Q:n in it) +sub send_dx_spot +{ + my $self = shift; + my $line = shift; + my $mode = shift; + + my @dxchan = DXChannel::get_all(); + + foreach my $dxchan (@dxchan) { + next unless $dxchan->is_user; + my $user = $dxchan->{user}; + next unless $user->wantrbn; + my $want = 0; + ++$want if $user->wantbeacon && $mode =~ /^BEA|NCD/; + ++$want if $user->wantcw && $mode =~ /^CW/; + ++$want if $user->wantrtty && $mode =~ /^RTTY/; + ++$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. + + $dxchan->send($line) if $want; + } +} 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index d3b24ba9..ebebcccc 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -31,6 +31,7 @@ $yes = 'Yes'; # visual representation of yes $no = 'No'; # ditto for no $user_interval = 11*60; # the interval between unsolicited prompts if no traffic + # make sure that modules are searched in the order local then perl BEGIN { umask 002; @@ -90,12 +91,11 @@ use DXVars; use SysVar; # order here is important - DXDebug snarfs Carp et al so that Mojo errors go into the debug log -use DXDebug; use Mojolicious 7.26; use Mojo::IOLoop; - $DOWARN = 1; +use DXDebug; use Msg; use IntMsg; use Internet; @@ -568,14 +568,14 @@ sub setup_start my $oldsort = $ref->sort; if ($oldsort ne 'S') { $ref->sort('S'); - dbg "Resetting node type from $oldsort -> DXSpider ('S')"; + dbg("Resetting node type from $oldsort -> DXSpider ('S')"); } $ref = DXUser::get($myalias); die "$myalias missing, run the create_sysop.pl script and please RTFM" unless $ref && $ref->priv == 9; $oldsort = $ref->sort; if ($oldsort ne 'U') { $ref->sort('U'); - dbg "Resetting sysop user type from $oldsort -> User ('U')"; + dbg("Resetting sysop user type from $oldsort -> User ('U')"); } } -- 2.34.1