From 337f38bfac57a5e5df34c63094fb869b0e2f6bee Mon Sep 17 00:00:00 2001 From: djk Date: Sun, 13 Dec 1998 00:47:32 +0000 Subject: [PATCH] 1. Incorporated sh/st, (un)set/lockout, forward/opername from Iain G0RDI 2. Added group handling with (un)set/group, show/group. This allows arbitrary groups to be formed (for ann/ for example) and is also used to 'filter' spots, announces, wwvs etc into groups of cluster nodes (useful for creating disjoint cluster networks) 3. **** CHANGE mylongtitude to mylongitude in DXVars.pm **** 4. Altered QRA locator routines so they work correctly! 5. Fixed all commands that had the wrong mylat(itude) and mylong(itude) names in. --- Changes | 10 ++++ cmd/forward/opername.pl | 33 ++++++++++++ cmd/reply.pl | 108 +++++++++++++++++++++------------------- cmd/set/lockout.pl | 28 +++++++++++ cmd/show/heading.pl | 4 +- cmd/show/qra.pl | 46 +++++++++++------ cmd/show/station.pl | 81 +++++++++++++++++++++--------- cmd/unset/lockout.pl | 28 +++++++++++ perl/DXBearing.pm | 86 +++++++++++++------------------- perl/DXChannel.pm | 4 ++ perl/DXCluster.pm | 1 + perl/DXCommandmode.pm | 2 +- perl/DXProt.pm | 4 ++ perl/DXUser.pm | 96 ++++++++++++++++++++++------------- perl/DXUtil.pm | 7 +-- perl/DXVars.pm | 2 +- perl/Messages | 8 ++- perl/cluster.pl | 10 +++- 18 files changed, 372 insertions(+), 186 deletions(-) create mode 100644 cmd/forward/opername.pl create mode 100644 cmd/set/lockout.pl create mode 100644 cmd/unset/lockout.pl diff --git a/Changes b/Changes index 8b155a08..19c7570f 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,13 @@ +12Dec98======================================================================== +1. Incorporated sh/st, (un)set/lockout, forward/opername from Iain G0RDI +2. Added group handling with (un)set/group, show/group. This allows arbitrary +groups to be formed (for ann/ for example) and is also used to 'filter' +spots, announces, wwvs etc into groups of cluster nodes (useful for creating +disjoint cluster networks) +3. **** CHANGE mylongtitude to mylongitude in DXVars.pm **** +4. Altered QRA locator routines so they work correctly! +5. Fixed all commands that had the wrong mylat(itude) and mylong(itude) names +in. 07Dec98======================================================================== 1. Added set/name, set/qra, set/location, set/qth, set/homenode, set/bbs, set/email diff --git a/cmd/forward/opername.pl b/cmd/forward/opername.pl new file mode 100644 index 00000000..c8db6567 --- /dev/null +++ b/cmd/forward/opername.pl @@ -0,0 +1,33 @@ +# +# Cause node to send PC41 info frames +# +# Copyright (c) 1998 - Iain Philipps G0RDI +# +# Mods by Dirk Koopman G1TLH 12Dec98 +# + +my ($self, $line) = @_; +my @f = split /\s+/, uc $line; +my @out; +my $call; + +if (@f == 0) { + return (1, $self->('e6')) if ($self->priv < 5); +} else { + foreach $call (@f) { + my $ref = DXUser->get_current($call); + if ($ref) { + my $name = $ref->name; + my $qth = $ref->qth; + my $lat = $ref->lat; + my $long = $ref->long; + my $node = $ref->homenode; + my $latlong = DXBearing::lltos($lat, $long) if $lat && $long; + DXProt::broadcast_ak1a(DXProt::pc41($call, 1, $name), $DXProt::me) if $name; + DXProt::broadcast_ak1a(DXProt::pc41($call, 2, $qth), $DXProt::me) if $qth; + DXProt::broadcast_ak1a(DXProt::pc41($call, 3, $latlong), $DXProt::me) if $latlong; + DXProt::broadcast_ak1a(DXProt::pc41($call, 4, $node), $DXProt::me) if $node; + } + } +} +return (1, @out); diff --git a/cmd/reply.pl b/cmd/reply.pl index ce9d6916..c5ceaddf 100644 --- a/cmd/reply.pl +++ b/cmd/reply.pl @@ -23,60 +23,64 @@ my $loc; #$DB::single = 1; if ($self->state eq "prompt") { - - my @f = split /\s+/, $line; - - # now deal with real message inputs - # parse out send line for various possibilities - $loc = $self->{loc} = {}; - - my $i = 0; - $f[0] = uc $f[0]; - $loc->{private} = '1'; - if ($f[0] eq 'B' || $f[0] =~ /^NOP/oi) { - $loc->{private} = '0'; - $i += 1; - } elsif ($f[0] eq 'P' || $f[0] =~ /^PRI/oi) { - $i += 1; - } - - $loc->{rrreq} = '0'; - if (uc $f[$i] eq 'RR') { - $loc->{rrreq} = '1'; - $i++; - } - - my $oref; - - # check we have a reply number - if ($i > @f) { - if (!($oref = DXMsg::get($self->lastread))) { - delete $self->{loc}; - #return (0, $self->msg('esend2')); - return (0, "need a message number"); + + my @f = split /\s+/, $line if $line; + + # now deal with real message inputs + # parse out send line for various possibilities + $loc = $self->{loc} = {}; + + my $i = 0; + $loc->{private} = '1'; + if ($i < @f) { + if ($f[0] =~ /^(B|NOP)/oi) { + $loc->{private} = '0'; + $i += 1; + } elsif ($f[0] =~ /^P/oi) { + $i += 1; + } } - } else { - $oref = DXMsg::get($f[$i]); - if (!$oref) { - delete $self->{loc}; - return (0, "can't access message $i"); + + if ($i < @f) { + $loc->{rrreq} = '0'; + if (uc $f[$i] eq 'RR') { + $loc->{rrreq} = '1'; + $i++; + } } - } - - # now save all the 'to' callsigns for later - my $to = $oref->from; - $loc->{to} = [ $to ]; # to is an array - $loc->{subject} = $oref->subject; - $loc->{subject} = "Re: " . $loc->{subject} if !($loc->{subject} =~ /^Re:.\s/io); - - # find me and set the state and the function on my state variable to - # keep calling me for every line until I relinquish control - $self->func("DXMsg::do_send_stuff"); - $self->state('sendbody'); - #push @out, $self->msg('sendsubj'); - push @out, "Reply to: $to"; - push @out, "Subject : $loc->{subject}"; - push @out, "Enter Message /EX (^Z) to send or /ABORT (^Y) to exit"; + my $oref; + + # check we have a reply number + # $DB::single = 1; + + if ($i < @f) { + $oref = DXMsg::get($f[$i]); + if (!$oref) { + delete $self->{loc}; + return (0, "can't access message $i"); + } + } else { + if (!($oref = DXMsg::get($self->lastread))) { + delete $self->{loc}; + #return (0, $self->msg('esend2')); + return (0, "need a message number"); + } + } + + # now save all the 'to' callsigns for later + my $to = $oref->from; + $loc->{to} = [ $to ]; # to is an array + $loc->{subject} = $oref->subject; + $loc->{subject} = "Re: " . $loc->{subject} if !($loc->{subject} =~ /^Re:\s/io); + + # find me and set the state and the function on my state variable to + # keep calling me for every line until I relinquish control + $self->func("DXMsg::do_send_stuff"); + $self->state('sendbody'); + #push @out, $self->msg('sendsubj'); + push @out, "Reply to: $to"; + push @out, "Subject : $loc->{subject}"; + push @out, "Enter Message /EX (^Z) to send or /ABORT (^Y) to exit"; } return (1, @out); diff --git a/cmd/set/lockout.pl b/cmd/set/lockout.pl new file mode 100644 index 00000000..a1e83c32 --- /dev/null +++ b/cmd/set/lockout.pl @@ -0,0 +1,28 @@ +# +# lock a user out +# +# Copyright (c) 1998 Iain Phillips G0RDI +# +# $Id$ +# +my ($self, $line) = @_; +my @args = split /\s+/, $line; +my $call; +# my $priv = shift @args; +my @out; +my $user; +my $ref; + +return (1, $self->msg('e5')) if $self->priv < 9; + +foreach $call (@args) { + $call = uc $call; + if ($ref = DXUser->get_current($call)) { + $ref->lockout(1); + $ref->put(); + push @out, $self->msg("lockout", $call); + } else { + push @out, $self->msg('e3', 'set/lockout', $call); + } +} +return (1, @out); diff --git a/cmd/show/heading.pl b/cmd/show/heading.pl index b7dd05c9..aa7bb2f8 100644 --- a/cmd/show/heading.pl +++ b/cmd/show/heading.pl @@ -13,8 +13,8 @@ my $lat = $self->user->lat; my $long = $self->user->long; if (!$long && !$lat) { push @out, $self->msg('heade1'); - $lat = $main::mylat; - $long = $main::mylong; + $lat = $main::mylatitude; + $long = $main::mylongitude; } foreach $l (@list) { diff --git a/cmd/show/qra.pl b/cmd/show/qra.pl index 8e91cf5f..fe3f08ab 100644 --- a/cmd/show/qra.pl +++ b/cmd/show/qra.pl @@ -1,5 +1,7 @@ # -# show the distance and bearing each QRA locator +# show the distance and bearing to a QRA locator +# +# you can enter two qra locators and it will calc the distance between them # # $Id$ # @@ -13,21 +15,37 @@ my $lat = $self->user->lat; my $long = $self->user->long; if (!$long && !$lat) { push @out, $self->msg('heade1'); - $lat = $main::mylat; - $long = $main::mylong; + $lat = $main::mylatitude; + $long = $main::mylongitude; } -foreach $l (@list) { - # locators ---> - if (DXBearing::is_qra($l) || $l =~ /^[A-Za-z][A-Za-z]\d\d$/) { - my $qra = uc $l; - $qra .= 'MM' if $l =~ /^[A-Za-z][A-Za-z]\d\d$/; - - my ($qlat, $qlong) = DXBearing::qratoll($qra); - my ($b, $dx) = DXBearing::bdist($lat, $long, $qlat, $qlong); - my ($r, $rdx) = DXBearing::bdist($qlat, $qlong, $lat, $long); - push @out, sprintf "%-9s Bearing: %.0f Recip: %.0f %.0fKm %.0fMi", $qra, $b, $r, $dx, $dx * 0.62133785; - } +return (1, $self->msg('qrashe1')) unless @list > 0; +return (1, $self->msg('qrae2')) unless (DXBearing::is_qra($list[0]) || $list[0] =~ /^[A-Za-z][A-Za-z]\d\d$/); + +#print "$lat $long\n"; + +my $l = uc $list[0]; +my $f; + +if (@list > 1) { + $f = $l; + $f .= 'MM' if $f =~ /^[A-Z][A-Z]\d\d$/; + ($lat, $long) = DXBearing::qratoll($f); + #print "$lat $long\n"; + + return (1, $self->msg('qrae2')) unless (DXBearing::is_qra($list[1]) || $list[1] =~ /^[A-Za-z][A-Za-z]\d\d$/); + $l = uc $list[1]; } +$l .= 'MM' if $l =~ /^[A-Z][A-Z]\d\d$/; + +my ($qlat, $qlong) = DXBearing::qratoll($l); +#print "$qlat $qlong\n"; +my ($b, $dx) = DXBearing::bdist($lat, $long, $qlat, $qlong); +my ($r, $rdx) = DXBearing::bdist($qlat, $qlong, $lat, $long); +my $to = " -> $list[1]" if $f; +my $from = $list[0]; + +push @out, sprintf "$list[0]$to Bearing: %.0f Deg. Recip: %.0f Deg. %.0fMi. %.0fKm.", $b, $r, $dx * 0.62133785, $dx; + return (1, @out); diff --git a/cmd/show/station.pl b/cmd/show/station.pl index 0f214033..d3a70865 100644 --- a/cmd/show/station.pl +++ b/cmd/show/station.pl @@ -3,40 +3,73 @@ # # Copyright (c) 1998 - Dirk Koopman G1TLH # -# $Id$ +# Modifications by Iain Philipps G0RDI, 07-Dec-1998 # my ($self, $line) = @_; my @f = split /\s+/, uc $line; my @out; my $call; +my $seek; if (@f == 0) { - return (1, "*** no station specified ***") if ($self->priv < 5); - my @calls = DXUser::get_all_calls(); - foreach $call (@calls) { - my $ref = DXUser->get_current($call); - next if !$ref; - my $sort = $ref->sort; - my $qth = $ref->qth; - my $home = $ref->node; - push @out, "$call $sort $qth $home"; - } + return (1, $self->msg('e6')) if ($self->priv < 5); + my @calls = DXUser::get_all_calls(); + foreach $call (@calls) { + my $ref = DXUser->get_current($call); + next if !$ref; + my $lat = $ref->lat; + my $long = $ref->long; + my $latlong = DXBearing::lltos($lat, $long) if $lat && $long; + push @out, sprintf "%-9s %s %-12.12s %-27.27s %-9s %s %s", $call, $ref->sort, $ref->name, $ref->qth, $ref->homenode, $latlong, $ref->qra; + } } else { - foreach $call (@f) { - my $ref = DXUser->get_current($call); - if ($ref) { - my $name = $ref->name; - my $qth = $ref->qth; - my $lat = $ref->lat; - my $long = $ref->long; - my $node = $ref->node; -# my $homenode = $ref->homenode; - push @out, "$call $qth $lat $long $node"; - } else { - push @out, "$call not known"; + foreach $call (@f) { + my $ref = DXUser->get_current($call); + if ($ref) { + my $name = $ref->name; + my $qth = $ref->qth; + my $lat = $ref->lat; + my $long = $ref->long; + my $node = $ref->node; + my $homenode = $ref->homenode; + my $lastin = $ref->lastin; + my $latlong = DXBearing::lltos($lat, $long) if $lat || $long; + my $last = DXUtil::cldatetime($lastin) if $ref->lastin; + my $qra = $ref->qra; + $qra = DXBearing::lltoqra($lat, $long) if !$qra && ($lat || $long); + my $from; + my ($dx, $bearing, $miles); + if ($latlong) { + my ($hlat, $hlong) = ($self->user->lat, $self->user->long); + ($hlat, $hlong) = DXBearing::qratoll($self->user->qra) if $self->user->qra && !$hlat && !$hlong; + if (!$hlat && !$hlong) { + $from = "From $main::mycall"; + $hlat = $main::mylatitude; + $hlong = $main::mylongitude; + } + ($bearing, $dx) = DXBearing::bdist($hlat, $hlong, $lat, $long); + $miles = $dx * 0.62133785; + } + + my $cref = DXCluster->get($call); + my $seek = $cref->mynode->call if $cref; + + if ($seek) { + push @out, "User : $call (at $seek)"; + } else { + push @out, "User : $call"; + } + push @out, "Name : $name" if $name; + push @out, "Last Connect : $last" if $last; + push @out, "QTH : $qth" if $qth; + push @out, "Location : $latlong ($qra)" if $latlong || $qra ; + push @out, sprintf("Heading : %.0f Deg %.0f Mi. %.0f Km. $from", $bearing, $miles, $dx) if $latlong; + push @out, "Home Node : $homenode" if $homenode; + } else { + push @out, $self->msg('usernf', $call); + } } - } } return (1, @out); diff --git a/cmd/unset/lockout.pl b/cmd/unset/lockout.pl new file mode 100644 index 00000000..71641c6e --- /dev/null +++ b/cmd/unset/lockout.pl @@ -0,0 +1,28 @@ +# +# unlock a locked out user +# +# Copyright (c) 1998 Iain Phillips G0RDI +# +# $Id$ +# +my ($self, $line) = @_; +my @args = split /\s+/, $line; +my $call; +# my $priv = shift @args; +my @out; +my $user; +my $ref; + +return (1, $self->msg('e5')) if $self->priv < 9; + +foreach $call (@args) { + $call = uc $call; + if ($ref = DXUser->get_current($call)) { + $ref->lockout(0); + $ref->put(); + push @out, $self->msg("lockoutun", $call); + } else { + push @out, $self->msg('e3', 'unset/lockout', $call); + } +} +return (1, @out); diff --git a/perl/DXBearing.pm b/perl/DXBearing.pm index 4c8c3eea..a2eaeba5 100644 --- a/perl/DXBearing.pm +++ b/perl/DXBearing.pm @@ -14,60 +14,54 @@ package DXBearing; use POSIX; +use DXUtil; use strict; use vars qw($pi); $pi = 3.14159265358979; -# half a qra to lat long translation -sub _half_qratoll -{ - my ($l, $n, $m) = @_; - my $lat = ord($l) - ord('A'); - $lat = $lat * 10 + (ord($n) - ord('0')); - $lat = $lat * 24 + (ord($m) - ord('A')); - $lat -= (2160 + 0.5); - $lat = $lat * ($pi/4320); - -} # convert a qra locator into lat/long in DEGREES sub qratoll { my $qra = uc shift; - my $long = _half_qratoll((unpack 'AAAAAA', $qra)[0,2,4]) * 2; - my $lat = _half_qratoll((unpack 'AAAAAA', $qra)[1,3,5]); - return (rd($lat), rd($long)); -} - -sub _part_lltoqra -{ - my ($t, $f, $n, $e) = @_; - $n = $f * ($n - int($n)); - $e = $f * ($e - int($e)); - my $q = chr($t+$e) . chr($t+$n); - return ($q, $n, $e); + my ($p1, $p2, $p3, $p4, $p5, $p6) = unpack 'AAAAAA', $qra; + ($p1, $p2, $p3, $p4, $p5, $p6) = (ord($p1)-ord('A'), ord($p2)-ord('A'), ord($p3)-ord('0'), ord($p4)-ord('0'), ord($p5)-ord('A'), ord($p6)-ord('A') ); + + my $long = ($p1*20) + ($p3*2) + (($p5+0.5)/12) - 180; + my $lat = ($p2*10) + $p4 + (($p6+0.5)/24) - 90; + return ($lat, $long); } # convert a lat, long in DEGREES to a qra locator sub lltoqra { - my $lat = dr(shift); - my $long = dr(shift); - my $t = 1/6.283185; + my $lat = shift; + my $long = shift; - $long = $long * $t +.5 ; - $lat = $lat * $t * 2 + .5 ; + my $v; + my ($p1, $p2, $p3, $p4, $p5, $p6); + + $lat += 90; + $long += 180; + $v = int($long / 20); + $long -= ($v * 20); + $p1 = chr(ord('A') + $v); + $v = int($lat / 10); + $lat -= ($v * 10); + $p2 = chr(ord('A') + $v); + $p3 = int($long/2); + $p4 = int($lat); + $long -= $p3*2; + $lat -= $p4; + $p3 = chr(ord('0')+$p3); + $p4 = chr(ord('0')+$p4); + $p5 = int((12 * $long) ); + $p6 = int((24 * $lat) ); + $p5 = chr(ord('A')+$p5); + $p6 = chr(ord('A')+$p6); - my $q; - my $qq; - ($q, $lat, $long) = _part_lltoqra(ord('A'), 18, $lat, $long); - $qq = $q; - ($q, $lat, $long) = _part_lltoqra(ord('0'), 10, $lat, $long); - $qq .= $q; - ($q, $lat, $long) = _part_lltoqra(ord('A'), 24, $lat, $long); - $qq .= $q; - return $qq; + return "$p1$p2$p3$p4$p5$p6"; } # radians to degrees @@ -100,6 +94,7 @@ sub bdist my $he = dr(shift); my $n = dr(shift); my $e = dr(shift); + return (0, 0) if $hn == $n && $he == $e; my $co = cos($he-$e)*cos($hn)*cos($n)+sin($hn)*sin($n); my $ca = atan(abs(sqrt(1-$co*$co)/$co)); $ca = $pi-$ca if $co < 0; @@ -129,19 +124,8 @@ sub stoll sub lltos { my ($lat, $long) = @_; - my ($latd, $latm, $longd, $longm); - my $latl = $lat > 0 ? 'N' : 'S'; - my $longl = $long > 0 ? 'E' : 'W'; - - $lat = abs $lat; - $latd = int $lat; - $lat -= $latd; - $latm = int (60 * $lat); - - $long = abs $long; - $longd = int $long; - $long -= $longd; - $longm = int (60 * $long); - return "$latd $latm $latl $longd $longm $longl"; + my $slat = slat($lat); + my $slong = slong($long); + return "$slat $slong"; } 1; diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 692bf98b..640bc4e5 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -66,6 +66,7 @@ use vars qw(%channels %valid); remotecmd => '9,doing rcmd,yesno', pagelth => '0,Page Length', pagedata => '9,Page Data Store', + group => '0,Access Group,parray', # used to create a group of users/nodes for some purpose or other ); # create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] @@ -83,6 +84,8 @@ sub alloc $self->{oldstate} = 0; $self->{lang} = $user->{lang} if defined $user; $self->{lang} = $main::lang if !$self->{lang}; + $user->new_group() if !$user->group; + $self->{group} = $user->group; bless $self, $pkg; return $channels{$call} = $self; } @@ -117,6 +120,7 @@ sub get_by_cnum sub del { my $self = shift; + $self->{group} = undef; # belt and braces delete $channels{$self->{call}}; } diff --git a/perl/DXCluster.pm b/perl/DXCluster.pm index 09001b20..0eb98a4b 100644 --- a/perl/DXCluster.pm +++ b/perl/DXCluster.pm @@ -224,6 +224,7 @@ sub new my $self = $pkg->alloc($dxchan, $call, $confmode, $here); $self->{pcversion} = $pcversion; $self->{list} = { } ; + $self->{mynode} = $self; # for sh/station $nodes++; dbg('cluster', "allocating node $call to cluster\n"); return $self; diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index a6e5e2f7..91d268b0 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -86,7 +86,7 @@ sub start $self->send($self->msg('qthe1')) if !$user->qth; $self->send($self->msg('qll')) if !$user->qra || (!$user->lat && !$user->long); $self->send($self->msg('hnodee1')) if !$user->qth; - + $self->send($self->msg('pr', $call)); } diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 35aae2e5..4fce8298 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -80,6 +80,7 @@ sub start } $self->state('init'); $self->pc50_t(time); + Log('DXProt', "$call connected"); } @@ -219,6 +220,7 @@ sub normal my $user = DXUser->get_current($call); $user = DXUser->new($call) if !$user; $user->node($node->call); + $user->lastin($main::systime); $user->homenode($node->call) if !$user->homenode; $user->put; } @@ -269,6 +271,7 @@ sub normal $user->sort('A'); $user->node($call); $user->homenode($call); + $user->lastin($main::systime); $user->put; } } @@ -528,6 +531,7 @@ sub finish # now broadcast to all other ak1a nodes that I have gone broadcast_ak1a(pc21($call, 'Gone.'), $self); + Log('DXProt', $call . " Disconnected"); $ref->del() if $ref; } diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 0af77f04..65948d59 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -47,6 +47,7 @@ $filename = undef; reg => '0,Registered?,yesno', # is this user registered? lang => '0,Language', hmsgno => '0,Highest Msgno', + group => '0,Access Group,parray', # used to create a group of users/nodes for some purpose or other ); no strict; @@ -195,6 +196,67 @@ sub fields return keys(%valid); } +# +# group handling +# + +# add one or more groups +sub add_group +{ + my $self = shift; + my $ref = $self->{group} || [ 'local' ]; + $self->{group} = $ref if !$self->{group}; + push @$ref, @_ if @_; +} + +# remove one or more groups +sub del_group +{ + my $self = shift; + my $ref = $self->{group} || [ 'local' ]; + my @in = @_; + + $self->{group} = $ref if !$self->{group}; + + @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref; +} + +# does this thing contain all the groups listed? +sub union +{ + my $self = shift; + my $ref = $self->{group}; + my $n; + + return 0 if !$ref || @_ == 0; + return 1 if @$ref == 0 && @_ == 0; + for ($n = 0; $n < @_; ) { + for (@$ref) { + my $a = $_; + $n++ if grep $_ eq $a, @_; + } + } + return $n >= @_; +} + +# simplified group test just for one group +sub in_group +{ + my $self = shift; + my $s = shift; + my $ref = $self->{group}; + + return 0 if !$ref; + return grep $_ eq $s, $ref; +} + +# set up a default group (only happens for them's that connect direct) +sub new_group +{ + my $self = shift; + $self->{group} = [ 'local' ]; +} + # # return a prompt for a field # @@ -205,40 +267,6 @@ sub field_prompt return $valid{$ele}; } -# -# enter an element from input, returns 1 for success -# - -sub enter -{ - my ($self, $ele, $value) = @_; - return 0 if (!defined $valid{$ele}); - chomp $value; - return 0 if $value eq ""; - if ($ele eq 'long') { - my ($longd, $longm, $longl) = $value =~ /(\d+) (\d+) ([EWew])/; - return 0 if (!$longl || $longd < 0 || $longd > 180 || $longm < 0 || $longm > 59); - $longd += ($longm/60); - $longd = 0-$longd if (uc $longl) eq 'W'; - $self->{'long'} = $longd; - return 1; - } elsif ($ele eq 'lat') { - my ($latd, $latm, $latl) = $value =~ /(\d+) (\d+) ([NSns])/; - return 0 if (!$latl || $latd < 0 || $latd > 90 || $latm < 0 || $latm > 59); - $latd += ($latm/60); - $latd = 0-$latd if (uc $latl) eq 'S'; - $self->{'lat'} = $latd; - return 1; - } elsif ($ele eq 'qra') { - $self->{'qra'} = UC $value; - return 1; - } else { - $self->{$ele} = $value; # default action - return 1; - } - return 0; -} - # some variable accessors sub sort { diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 667194af..9f63c890 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -77,7 +77,7 @@ sub slat $let = $n >= 0 ? 'N' : 'S'; $n = abs $n; $deg = int $n; - $min = int (($n - $deg) * 60); + $min = int ((($n - $deg) * 60) + 0.5); return "$deg $min $let"; } @@ -89,7 +89,7 @@ sub slong $let = $n >= 0 ? 'E' : 'W'; $n = abs $n; $deg = int $n; - $min = int (($n - $deg) * 60); + $min = int ((($n - $deg) * 60) + 0.5); return "$deg $min $let"; } @@ -118,7 +118,8 @@ sub promptf # take an arg as an array list and print it sub parray { - return join(', ', @{shift}); + my $ref = shift; + return join(', ', @{$ref}); } # take the arg as an array reference and print as a list of pairs diff --git a/perl/DXVars.pm b/perl/DXVars.pm index b35689bc..91f43707 100644 --- a/perl/DXVars.pm +++ b/perl/DXVars.pm @@ -35,7 +35,7 @@ $myalias = "G1TLH"; $mylatitude = +52.68584579; # Your Longtitude (+)ve = East, (-)ve = West in degrees and decimal degrees -$mylongtitude = +0.94518260; +$mylongitude = +0.94518260; # Your locator (yes I know I can calculate it - eventually) $mylocator = "JO02LQ"; diff --git a/perl/Messages b/perl/Messages index 1dee13e3..16ad509e 100644 --- a/perl/Messages +++ b/perl/Messages @@ -34,7 +34,7 @@ package DXM; e3 => '$_[0]: $_[1] not found', e4 => 'Need at least a prefix or callsign', e5 => 'Not Allowed', - e6 => 'Need a callsign', + e6 => '*** No station specified ***', e7 => 'callsign $_[0] not visible on the cluster', e8 => 'Need a callsign and some text', e9 => 'Need at least some text', @@ -56,6 +56,8 @@ package DXM; loce1 => 'Please enter your location,, set/location ', loce2 => 'Don\'t recognise \"$_[0]\" as a Lat/Long (eg 52 20 N 0 16 E)', loc => 'Your Lat/Long is now \"$_[0]\"', + lockout => '$_[0] Locked out', + lockoutun => '$_[0] Unlocked', m2 => '$_[0] Information: $_[1]', namee1 => 'Please enter your name, set/name ', namee2 => 'Can\'t find user $_[0]!', @@ -74,7 +76,8 @@ package DXM; qll => 'Please enter your location with set/location or set/qra', qthe1 => 'Please enter your QTH, set/qth ', qth => 'Your QTH is now \"$_[0]\"', - qrae1 => 'Please enter your QRA locator, set/qra ', + qrae1 => 'Please enter your QRA locator, set/qra (eg set/qra JO02LQ)', + qrashe1 => 'Please enter a QRA locator, eg sh/qra JO02LQ or sh/qra JO02LQ IO93NS', qrae2 => 'Don\'t recognise \"$_[0]\" as a QRA locator (eg JO02LQ)', qra => 'Your QRA Locator is now \"$_[0]\"', rcmdo => 'RCMD \"$_[0]\" sent to $_[1]', @@ -84,6 +87,7 @@ package DXM; shutting => '$main::mycall shutting down...', talks => 'Talk flag set on $_[0]', talku => 'Talk flag unset on $_[0]', + usernf => '*** User record for $_[0] not found ***', wwvs => 'WWV flag set on $_[0]', wwvu => 'WWV flag unset on $_[0]', }, diff --git a/perl/cluster.pl b/perl/cluster.pl index 1eb82078..e343cc0b 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -48,7 +48,7 @@ package main; @inqueue = (); # the main input queue, an array of hashes $systime = 0; # the time now (in seconds) -$version = 1.9; # the version no of the software +$version = "1.10"; # the version no of the software $starttime = 0; # the starting time of the cluster # handle disconnections @@ -108,7 +108,13 @@ sub rec $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems } - + # is he locked out ? + if ($user->lockout) { + Log('DXCommand', "$call is locked out, disconnected"); + $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect + return; + } + # create the channel $dxchan = DXCommandmode->new($call, $conn, $user) if ($user->sort eq 'U'); $dxchan = DXProt->new($call, $conn, $user) if ($user->sort eq 'A'); -- 2.34.1