From: Dirk Koopman Date: Sat, 29 Jan 2022 17:23:29 +0000 (+0000) Subject: headline: RBN set/seeme X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?p=spider.git;a=commitdiff_plain;h=cc49b8f8c2ec3a975c7ace3f5bd8679580288406 headline: RBN set/seeme 29Jan22======================================================================= 1. Implement RBN set/seeme which displays any passing RBN spots for your callsign in "raw" format. 28Jan22======================================================================= 1. Add Capabilities Line to logged in users. 2. Make absolutely sure that all DB_Files are closed correctly. 3. Introduce (un)set/debug rbnchan to control the visualisation of raw RBN input lines. --- diff --git a/Changes b/Changes index 8c83dc72..f44a0b65 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,11 @@ +29Jan22======================================================================= +1. Implement RBN set/seeme which displays any passing RBN spots for your + callsign in "raw" format. +28Jan22======================================================================= +1. Add Capabilities Line to logged in users. +2. Make absolutely sure that all DB_Files are closed correctly. +3. Introduce (un)set/debug rbnchan to control the visualisation of raw RBN + input lines. 25Jan22======================================================================= 1. Fixed grepdbg so that it does what -help says it does. 24Jan22======================================================================= diff --git a/cmd/set/badip.pl b/cmd/set/badip.pl new file mode 100644 index 00000000..962fc641 --- /dev/null +++ b/cmd/set/badip.pl @@ -0,0 +1,24 @@ +# +# set list of bad dx nodes +# +# Copyright (c) 2021 - Dirk Koopman G1TLH +# +# +# +my ($self, $line) = @_; +return (1, $self->msg('e5')) if $self->remotecmd; +# are we permitted? +return (1, $self->msg('e5')) if $self->priv < 6; +my @out; +my @added; +my @in = split /\s+/, $line; +return (1, "set/badip: need IP, IP-IP or IP/24") unless @in; +for (@in) { + eval{ DXCIDR::add($_); }; + return (1, "set/badip: $_ $@") if $@; + push @added, $_; +} +my $count = @added; +my $list = join ' ', @in; +push @out, "set/badip: added $count entries: $list"; +return (1, @out); diff --git a/cmd/set/seeme.pl b/cmd/set/seeme.pl new file mode 100644 index 00000000..f85ed48d --- /dev/null +++ b/cmd/set/seeme.pl @@ -0,0 +1,21 @@ +# +# set the ve7cc output flag +# +# Copyright (c) 2000 - Dirk Koopman +# +# +# + +my ($self, $line) = @_; +my @args = split /\s+/, $line; +my $call; +my @out; + +return (0, $self->msg('e5')) unless $self->isa('DXCommandmode'); + +$self->rbnseeme(1); +$self->user->rbnseeme(1); +RBN::add_seeme($self->call); + +push @out, $self->msg('ok'); +return (1, @out); diff --git a/cmd/show/badip.pl b/cmd/show/badip.pl new file mode 100644 index 00000000..73db65da --- /dev/null +++ b/cmd/show/badip.pl @@ -0,0 +1,28 @@ +# +# set list of bad dx nodes +# +# Copyright (c) 2021 - Dirk Koopman G1TLH +# +# +# +my ($self, $line) = @_; +return (1, $self->msg('e5')) if $self->remotecmd; +# are we permitted? +return (1, $self->msg('e5')) if $self->priv < 6; +my @out; +my @added; +my @in = split /\s+/, $line; +my @list= DXCIDR::list(); +foreach my $list (@list) { + if (@in) { + for (@in) { + if ($list =~ /$_/i) { + push @out, $list; + last; + } + } + } else { + push @out, $list; + } +} +return (1, @out); diff --git a/cmd/unset/registered.pl b/cmd/unset/registered.pl new file mode 100644 index 00000000..4876aea2 --- /dev/null +++ b/cmd/unset/registered.pl @@ -0,0 +1,82 @@ +# +# show/registered +# +# show all registered users +# +# Copyright (c) 2001 Dirk Koopman G1TLH +# +# +# + +sub handle +{ + my ($self, $line) = @_; + return (1, $self->msg('e5')) unless $self->priv >= 9; + + my @out; + + use DB_File; + + if ($line) { + $line =~ s/[^\w\-\/]+//g; + $line = "\U\Q$line"; + } + + if ($self->{_nospawn}) { + @out = generate($self, $line); + } else { + @out = $self->spawn_cmd("show/registered $line", sub { return (generate($self, $line)); }); + } + + return (1, @out); +} + +sub generate +{ + my $self = shift; + my $line = shift; + my @out; + my @val; + +# dbg("set/register line: $line"); + + my %call = (); + $call{$_} = 1 for split /\s+/, $line; + delete $call{'ALL'}; + + my ($action, $count, $key, $data) = (0,0,0,0); + unless (keys %call) { + for ($action = DXUser::R_FIRST, $count = 0; !$DXUser::dbm->seq($key, $data, $action); $action = DXUser::R_NEXT) { + if ($data =~ m{registered}) { + $call{$key} = 1; # possible candidate + } + } + } + + foreach $key (sort keys %call) { + my $u = DXUser::get_current($key); + if ($u && defined (my $r = $u->registered)) { + push @val, "${key}($r)"; + ++$count; + } + } + + my @l; + push @out, "Registration is " . ($main::reqreg ? "Required" : "NOT Required"); + foreach my $call (@val) { + if (@l >= 5) { + push @out, sprintf "%-14s %-14s %-14s %-14s %-14s", @l; + @l = (); + } + push @l, $call; + } + if (@l) { + push @l, "" while @l < 5; + push @out, sprintf "%-14s %-14s %-14s %-14s %-14s", @l; + } + + push @out, $self->msg('rec', $count); + return @out; + +} + diff --git a/cmd/unset/seeme.pl b/cmd/unset/seeme.pl new file mode 100644 index 00000000..4185372c --- /dev/null +++ b/cmd/unset/seeme.pl @@ -0,0 +1,20 @@ +# +# unset the RBN seeme flag +# +# Copyright (c) 2000 - Dirk Koopman +# +# +# + +my ($self, $line) = @_; +my @out; + +return (0, $self->msg('e5')) unless $self->isa('DXCommandmode'); + +$self->rbnseeme(0); +$self->user->rbnseeme(0); +$self->user->put; +RBN::del_seeme($self->call); + +push @out, $self->msg('ok'); +return (1, @out); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 7f4d996a..29919c7e 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -109,6 +109,7 @@ $count = 0; priv => '9,Privilege', prompt => '0,Required Prompt', rbnfilter => '5,RBN Filt-out', + rbnseeme => '0,RBN See Me,yesno', redirect => '0,Redirect messages to', registered => '9,Registered?,yesno', remotecmd => '9,doing rcmd,yesno', @@ -714,9 +715,14 @@ sub process_one while (my $data = shift @{$self->{inqueue}}) { my ($sort, $call, $line) = $self->decode_input($data); next unless defined $sort; - - # do the really sexy console interface bit! (Who is going to do the TK interface then?) - dbg("<- $sort $call $line") if $sort ne 'D' && isdbg('chan'); + + if ($sort ne 'D') { + if (isdbg('chan')) { + if (($self->is_rbn && isdbg('rbnchan')) || !$self->is_rbn) { + dbg("<- $sort $call $line") if isdbg('chan'); + } + } + } # handle A records my $user = $self->user; diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 8abd8d4e..8ed74de4 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -106,6 +106,7 @@ sub start $self->{name} = $name ? $name : $call; $self->send($self->msg('l2',$self->{name})); + $self->send("Capabilities: ve7cc rbn"); $self->state('prompt'); # a bit of room for further expansion, passwords etc $self->{priv} = $user->priv || 0; $self->{lang} = $user->lang || $main::lang || 'en'; @@ -142,12 +143,14 @@ sub start $self->{here} = 1; $self->{prompt} = $user->prompt if $user->prompt; $self->{lastmsgpoll} = 0; - + $self->{rbnseeme} = $user->rbnseeme; + RBN::add_seeme($call) if $self->{rbnseeme}; + # sort out new dx spot stuff $user->wantdxcq(0) unless defined $user->{wantdxcq}; $user->wantdxitu(0) unless defined $user->{wantdxitu}; $user->wantusstate(0) unless defined $user->{wantusstate}; - + # sort out registration if ($main::reqreg == 2) { $self->{registered} = !$user->registered; @@ -648,6 +651,7 @@ sub disconnect return if $self->{disconnecting}++; delete $self->{senddbg}; + RBN::del_seeme($call); my $uref = Route::User::get($call); my @rout; diff --git a/perl/DXDupe.pm b/perl/DXDupe.pm index ebb2aac4..696bbf84 100644 --- a/perl/DXDupe.pm +++ b/perl/DXDupe.pm @@ -29,6 +29,7 @@ sub init sub finish { + dbg("DXDupe finishing"); undef $dbm; untie %d; undef %d; @@ -100,4 +101,12 @@ sub listdups } return @out; } + +sub END +{ + if ($dbm) { + dbg("DXDupe ENDing"); + finish(); + } +} 1; diff --git a/perl/DXUser.pm b/perl/DXUser.pm index dd35c5e7..7b2ad7a7 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -51,6 +51,8 @@ my $json; buddies => '0,Buddies,parray', build => '1,Build', call => '0,Callsign', + clientoutput => '0,User OUT Format', + clientinput => '0,User IN Format', connlist => '1,Connections,parraydifft', dxok => '9,Accept DX Spots?,yesno', # accept his dx spots? email => '0,E-mail Address,parray', @@ -80,7 +82,7 @@ my $json; prompt => '0,Required Prompt', qra => '0,Locator', qth => '0,Home QTH', - rbnseeme => '0,RBN See Me', + rbnseeme => '0,RBN See Me,yesno', registered => '9,Registered?,yesno', startt => '0,Start Time,cldatetime', version => '1,Version', @@ -188,6 +190,7 @@ sub process sub finish { + dbg('DXUser finished'); $dbm->sync; undef $dbm; untie %u; @@ -975,7 +978,15 @@ sub recover LogDbg('command', $s); return ($s); } - + +sub END +{ + if ($dbm) { + print "DXUser Ended\n"; + finish(); + } +} + 1; __END__ diff --git a/perl/QSL.pm b/perl/QSL.pm index 1fd7130b..ec551221 100644 --- a/perl/QSL.pm +++ b/perl/QSL.pm @@ -47,6 +47,7 @@ sub init sub finish { + dbg("DXQSL finished"); $dbm->sync; undef $dbm; untie %u; @@ -148,4 +149,12 @@ sub encode return $json->encode($_[0]); } +sub END +{ + if ($dbm) { + dbg "DXQSL ENDing"; + finish(); + } +} + 1; diff --git a/perl/RBN.pm b/perl/RBN.pm index ec9f3946..7ad9093b 100644 --- a/perl/RBN.pm +++ b/perl/RBN.pm @@ -107,6 +107,9 @@ my $json; my $noinrush = 0; # override the inrushpreventor if set our $maxdeviants = 5; # the number of deviant QRGs to record for skimmer records +our %seeme; # the list of users that want to see themselves + + sub init { $json = DXJSON->new; @@ -331,6 +334,30 @@ sub normal my $nqrg = nearest(1, $qrg * 10); # normalised to nearest Khz my $sp = "$call|$nqrg"; # hopefully the skimmers will be calibrated at least this well! + # 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 > $now+3600; # too far ahead, drag it back one day + + # + # But before we do anything, if this call is in the seeme hash then just send the spot to them + # + if (exists $seeme{$call} && (my $scall = $seeme{$call})) { + my $uchan = DXChannel::get($call); + if ($uchan->is_user) { + if (isdbg('seeme')) { + dbg("seeme: $line"); + dbg( qq{seemme:decode or:$origin qr:$qrg ca:$call mo:$mode s:$s m:$m sp:$spd u:$u sort:$sort t:$t tx:$tx qra:$qra}); + } + my @s = Spot::prepare($qrg, $call, $utz, sprintf("%-3s %2ddB **SEEME**", $mode, $s), $origin.'-#'); + my $buf = $uchan->format_dx_spot(@s); + dbg("seeme: result '$buf'") if isdbg('seeme'); + $uchan->local_send('S', $buf) if $scall; + } else { + LogDbg("RBN Someone is playing silly persons $call is not a user and cannot do 'seeme', ignored and reset"); + delete $seeme{$call}; + } + } # find it? my $cand = $spots->{$sp}; unless ($cand) { @@ -386,11 +413,6 @@ sub normal return unless $noinrush || $self->{inrushpreventor} < $main::systime; # 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 > $now+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]; my @s = Spot::prepare($r->[RQrg], $r->[RCall], $r->[RUtz], '', $r->[ROrigin]); @@ -467,7 +489,6 @@ sub dx_spot my $quality = shift; my $cand = shift; my $call = $dxchan->{call}; - my $seeme = $dxchan->user->rbnseeme(); my $strength = 100; # because it could if we talk about FTx my $saver; my %zone; @@ -495,12 +516,6 @@ sub dx_spot ++$zone{$s->[SZone]}; # save the spotter's zone - # if the 'see me' flag is set, then show all the spots without further adornment (see set/rbnseeme for more info) - if ($seeme) { - send_final($dxchan, $s); - next; - } - # save the lowest strength one if ($r->[RStrength] < $strength) { $strength = $r->[RStrength]; @@ -567,7 +582,7 @@ sub send_final $buf = $dxchan->format_dx_spot(@$saver); $saver->[SOrigin] = $call; } - $dxchan->local_send('N', $buf); + $dxchan->local_send('R', $buf); } # per second @@ -941,4 +956,15 @@ sub check_cache return undef; } +sub add_seeme +{ + my $call = shift; + $seeme{$call} = 1; +} + +sub del_seeme +{ + my $call = shift; + delete $seeme{$call}; +} 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index f96fbfea..6ddaa30b 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -418,7 +418,7 @@ sub login return \&new_channel; } -our $ceasing; +my $ceasing; # cease running this program, close down all the connections nicely sub cease @@ -428,6 +428,8 @@ sub cease cluck("ceasing") if $ceasing; return if $ceasing++; + + dbg("DXSpider Ceasing"); unless ($is_win) { $SIG{'TERM'} = 'IGNORE'; @@ -451,8 +453,8 @@ sub cease UDPMsg::finish(); # end everything else + QSL::finish(); RBN::finish(); - DXUser::finish(); DXDupe::finish(); # close all databases @@ -463,6 +465,8 @@ sub cease $l->close_server; } + DXUser::finish(); + LogDbg('cluster', "DXSpider v$version build $build (git: $gitbranch/$gitversion) using perl $^V on $^O ended"); dbg("bye bye everyone - bye bye"); dbgclose(); @@ -596,7 +600,8 @@ sub setup_start my ($year) = (gmtime)[5]; $year += 1900; LogDbg('cluster', "DXSpider v$version build $build (git: $gitbranch/$gitversion) using perl $^V on $^O started"); - dbg("Copyright (c) 1998-$year Dirk Koopman G1TLH"); + LogDbg('cluster', "Copyright (c) 1998-$year Dirk Koopman G1TLH"); + LogDbg('cluster', "Capabilities: ve7cc rbn"); # load Prefixes dbg("loading prefixes ..."); @@ -891,3 +896,10 @@ cease(0); exit(0); +sub END +{ + unless ($ceasing) { + print "DXSpider Ending\n"; + cease(); + } +}