From b060a0a3ee72530aa3f10d453186a662b66d7efe Mon Sep 17 00:00:00 2001 From: djk Date: Sat, 28 Nov 1998 00:26:36 +0000 Subject: [PATCH] release 1.5 loads of fixes, but can now connect outbound, do logging, more messages remote commands for outside now work --- cmd/Aliases | 14 +- cmd/debug.pl | 2 +- cmd/dx.pl | 28 ++- cmd/kill.pl | 2 + cmd/reply.pl | 2 +- cmd/set/address.pl | 2 +- cmd/set/dx.pl | 4 +- cmd/set/here.pl | 4 +- cmd/set/node.pl | 6 +- cmd/set/privilege.pl | 27 +-- cmd/set/talk.pl | 4 +- cmd/set/wwv.pl | 4 +- cmd/shutdown.pl | 14 +- cmd/unset/announce.pl | 4 +- cmd/unset/dx.pl | 4 +- cmd/unset/here.pl | 4 +- cmd/unset/talk.pl | 4 +- cmd/unset/wwv.pl | 4 +- connect/gb7tlh | 9 +- data/bands.pl | 7 + perl/DXChannel.pm | 5 + perl/DXCommandmode.pm | 29 ++- perl/DXCron.pm | 2 +- perl/DXDebug.pm | 6 +- perl/DXLog.pm | 1 - perl/DXMsg.pm | 37 +++- perl/DXProt.pm | 60 ++++-- perl/DXProtout.pm | 14 ++ perl/Messages | 8 +- perl/Spot.pm | 3 +- perl/client.pl | 448 ++++++++++++++++++++++++++++-------------- perl/cluster.pl | 23 ++- perl/connect.pl | 180 ++++++++++++++--- 33 files changed, 703 insertions(+), 262 deletions(-) diff --git a/cmd/Aliases b/cmd/Aliases index f83d2641..6089171f 100644 --- a/cmd/Aliases +++ b/cmd/Aliases @@ -33,13 +33,13 @@ package CmdAlias; ], d => [ '^del', 'kill', 'kill', - '^di.*/all', 'directory all', 'directory', - '^di.*/b.*', 'directory bulletins', 'directory', - '^di.*/n.*', 'directory new', 'directory', - '^di.*/o.*', 'directory own', 'directory', - '^di.*/s.*', 'directory subject', 'directory', - '^di.*/(\d+)-(\d+)', 'directory $1-$2', 'directory', - '^di.*/(\d+)', 'directory $1', 'directory', + '^di\w*/a\w*', 'directory all', 'directory', + '^di\w*/b\w*', 'directory bulletins', 'directory', + '^di\w*/n\w*', 'directory new', 'directory', + '^di\w*/o\w*', 'directory own', 'directory', + '^di\w*/s\w*', 'directory subject', 'directory', + '^di\w*/(\d+)-(\d+)', 'directory $1-$2', 'directory', + '^di\w*/(\d+)', 'directory $1', 'directory', ], e => [ ], diff --git a/cmd/debug.pl b/cmd/debug.pl index 608f1daf..9b71d53c 100644 --- a/cmd/debug.pl +++ b/cmd/debug.pl @@ -9,7 +9,7 @@ # my $self = shift; -return if $self->priv < 9; +return (0) if $self->priv < 9; $DB::single = 1; diff --git a/cmd/dx.pl b/cmd/dx.pl index fdd07bf3..394cb7ab 100644 --- a/cmd/dx.pl +++ b/cmd/dx.pl @@ -28,14 +28,12 @@ if ($f[0] =~ /[A-Za-z]/) { $line =~ s/^$f[0]\s+$f[1]\s*//; } -# check the freq, if the number is < 1800 it is in Mhz (probably) -$freq = $freq * 1000 if $freq < 1800; - # bash down the list of bands until a valid one is reached my $bandref; my @bb; my $i; +# first in KHz L1: foreach $bandref (Bands::get_all()) { @bb = @{$bandref->band}; @@ -47,11 +45,31 @@ foreach $bandref (Bands::get_all()) { } } -push @out, "Frequency $freq not in band [usage: DX freq call comments]" if !$valid; +if (!$valid) { + + # try again in MHZ + $freq = $freq * 1000 if $freq; + +L2: + foreach $bandref (Bands::get_all()) { + @bb = @{$bandref->band}; + for ($i = 0; $i < @bb; $i += 2) { + if ($freq >= $bb[$i] && $freq <= $bb[$i+1]) { + $valid = 1; + last L2; + } + } + } +} + + + +push @out, $self->msg('dx1', $freq) if !$valid; # check we have a callsign :-) if ($spotted le ' ') { - push @out, "Need a callsign for the spot [usage: DX freq call comments]" ; + push @out, $self->msg('dx2'); + $valid = 0; } diff --git a/cmd/kill.pl b/cmd/kill.pl index d3de0beb..b6d193fe 100644 --- a/cmd/kill.pl +++ b/cmd/kill.pl @@ -12,6 +12,7 @@ my $msgno; my @out; my @body; my $ref; +my $call = $self->call; # $DB::single = 1; @@ -27,6 +28,7 @@ for $msgno (@f) { push @out, "Msg $msgno not available"; next; } + Log('msg', "Message $ref->{msgno} from $ref->{from} to $ref->{to} deleted by $call"); $ref->del_msg; push @out, "Message $msgno deleted"; } diff --git a/cmd/reply.pl b/cmd/reply.pl index c655b505..ce9d6916 100644 --- a/cmd/reply.pl +++ b/cmd/reply.pl @@ -67,7 +67,7 @@ if ($self->state eq "prompt") { my $to = $oref->from; $loc->{to} = [ $to ]; # to is an array $loc->{subject} = $oref->subject; - $loc->{subject} = "Re: " . $loc->{subject} if !($loc->{subject} =~ /^Re/io); + $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 diff --git a/cmd/set/address.pl b/cmd/set/address.pl index f31a982e..15e42579 100644 --- a/cmd/set/address.pl +++ b/cmd/set/address.pl @@ -23,6 +23,6 @@ if ($self->priv >= 5) { # allow a callsign as first arg } $user->addr($line); -push @out, DXM::msg('addr', $call, $line); +push @out, $self->msg('addr', $call, $line); return (1, @out); diff --git a/cmd/set/dx.pl b/cmd/set/dx.pl index 0acb39db..0edf6d54 100644 --- a/cmd/set/dx.pl +++ b/cmd/set/dx.pl @@ -18,9 +18,9 @@ foreach $call (@args) { my $chan = DXChannel->get($call); if ($chan) { $chan->dx(1); - push @out, DXM::msg('dxs', $call); + push @out, $self->msg('dxs', $call); } else { - push @out, DXM::msg('e3', "Set DX Spots", $call); + push @out, $self->msg('e3', "Set DX Spots", $call); } } return (1, @out); diff --git a/cmd/set/here.pl b/cmd/set/here.pl index aad69d02..136700f5 100644 --- a/cmd/set/here.pl +++ b/cmd/set/here.pl @@ -19,9 +19,9 @@ foreach $call (@args) { if ($ref) { $ref->here(1); DXProt::broadcast_ak1a(DXProt::pc24($ref)); - push @out, DXM::msg('heres', $call); + push @out, $self->msg('heres', $call); } else { - push @out, DXM::msg('e3', "Set Here", $call); + push @out, $self->msg('e3', "Set Here", $call); } } diff --git a/cmd/set/node.pl b/cmd/set/node.pl index 78baa189..fa0cf800 100644 --- a/cmd/set/node.pl +++ b/cmd/set/node.pl @@ -20,15 +20,15 @@ foreach $call (@args) { $call = uc $call; my $chan = DXChannel->get($call); if ($chan) { - push @out, DXM::msg('nodee1', $call); + push @out, $self->msg('nodee1', $call); } else { $user = DXUser->get($call); if ($user) { $user->sort('A'); $user->close(); - push @out, DXM::msg('node', $call); + push @out, $self->msg('node', $call); } else { - push @out, DXM::msg('e3', "Set Node", $call); + push @out, $self->msg('e3', "Set Node", $call); } } } diff --git a/cmd/set/privilege.pl b/cmd/set/privilege.pl index 87be2aa8..2513f85b 100644 --- a/cmd/set/privilege.pl +++ b/cmd/set/privilege.pl @@ -13,8 +13,7 @@ my $call; my $priv = shift @args; my @out; my $user; - -$DB::single = 1; +my $ref; return (0) if $self->priv < 9; @@ -23,14 +22,20 @@ if ($priv < 0 || $priv > 9) { } foreach $call (@args) { - $call = uc $call; - my $user = DXUser->get_current($call); - if ($user) { - $user->priv($priv); - $user->put(); - push @out, $self->msg('priv', $call); - } else { - push @out, $self->msg('e3', "Set Privilege", $call); - } + $call = uc $call; + if ($ref = DXChannel->get($call)) { + $ref->priv($priv); + $ref->user->priv($priv); + $ref->user->put(); + } + if (!$ref && ($user = DXUser->get($call))) { + $user->priv($priv); + $user->put(); + } + if ($ref || $user) { + push @out, $self->msg('priv', $call); + } else { + push @out, $self->msg('e3', "Set Privilege", $call); + } } return (1, @out); diff --git a/cmd/set/talk.pl b/cmd/set/talk.pl index 85b66c04..f24ede71 100644 --- a/cmd/set/talk.pl +++ b/cmd/set/talk.pl @@ -18,9 +18,9 @@ foreach $call (@args) { my $chan = DXChannel->get($call); if ($chan) { $chan->talk(1); - push @out, DXM::msg('talks', $call); + push @out, $self->msg('talks', $call); } else { - push @out, DXM::msg('e3', "Set Talk", $call); + push @out, $self->msg('e3', "Set Talk", $call); } } return (1, @out); diff --git a/cmd/set/wwv.pl b/cmd/set/wwv.pl index bfa04f25..701a385c 100644 --- a/cmd/set/wwv.pl +++ b/cmd/set/wwv.pl @@ -18,9 +18,9 @@ foreach $call (@args) { my $chan = DXChannel->get($call); if ($chan) { $chan->wwv(1); - push @out, DXM::msg('wwvs', $call); + push @out, $self->msg('wwvs', $call); } else { - push @out, DXM::msg('e3', "Set WWV", $call); + push @out, $self->msg('e3', "Set WWV", $call); } } return (1, @out); diff --git a/cmd/shutdown.pl b/cmd/shutdown.pl index 43b6fb75..c2350de0 100644 --- a/cmd/shutdown.pl +++ b/cmd/shutdown.pl @@ -4,7 +4,17 @@ # $Id$ # my $self = shift; +my $call = $self->call; +my $ref; + if ($self->priv >= 5) { - &main::cease(); + foreach $ref (DXChannel::get_all()) { + $ref->send_now("D", DXProt::pc39($main::mycall, "Shutdown by $call")) + if $ref->is_ak1a && $ref != $DXProt::me; + $ref->send_now("D", $self->msg('shutting')) if $ref->is_user; + } + + # give some time for the buffers to empty and then shutdown (see cluster.pl) + $main::decease = 250; } -return (0); +return (1); diff --git a/cmd/unset/announce.pl b/cmd/unset/announce.pl index cf750e25..9c6e9a9a 100644 --- a/cmd/unset/announce.pl +++ b/cmd/unset/announce.pl @@ -18,9 +18,9 @@ foreach $call (@args) { my $user = ($call eq $self->call) ? $self->user : DXUser->get($call); if ($user) { $user->ann(0); - push @out, DXM::msg('annu', $call); + push @out, $self->msg('annu', $call); } else { - push @out, DXM::msg('e3', "Unset Announce", $call); + push @out, $self->msg('e3', "Unset Announce", $call); } } return (1, @out); diff --git a/cmd/unset/dx.pl b/cmd/unset/dx.pl index 0ae6cc97..b1cf46ec 100644 --- a/cmd/unset/dx.pl +++ b/cmd/unset/dx.pl @@ -18,9 +18,9 @@ foreach $call (@args) { my $user = ($call eq $self->call) ? $self->user : DXUser->get($call); if ($user) { $user->dx(0); - push @out, DXM::msg('dxu', $call); + push @out, $self->msg('dxu', $call); } else { - push @out, DXM::msg('e3', "Unset DX Spots", $call); + push @out, $self->msg('e3', "Unset DX Spots", $call); } } return (1, @out); diff --git a/cmd/unset/here.pl b/cmd/unset/here.pl index 7311b5e8..48dbae2c 100644 --- a/cmd/unset/here.pl +++ b/cmd/unset/here.pl @@ -19,9 +19,9 @@ foreach $call (@args) { if ($ref) { $ref->here(0); DXProt::broadcast_ak1a(DXProt::pc24($ref)); - push @out, DXM::msg('hereu', $call); + push @out, $self->msg('hereu', $call); } else { - push @out, DXM::msg('e3', "Unset Here", $call); + push @out, $self->msg('e3', "Unset Here", $call); } } return (1, @out); diff --git a/cmd/unset/talk.pl b/cmd/unset/talk.pl index a3df8fa1..7b119c10 100644 --- a/cmd/unset/talk.pl +++ b/cmd/unset/talk.pl @@ -18,9 +18,9 @@ foreach $call (@args) { my $user = ($call eq $self->call) ? $self->user : DXUser->get($call); if ($user) { $user->talk(0); - push @out, DXM::msg('talku', $call); + push @out, $self->msg('talku', $call); } else { - push @out, DXM::msg('e3', "Unset Talk", $call); + push @out, $self->msg('e3', "Unset Talk", $call); } } return (1, @out); diff --git a/cmd/unset/wwv.pl b/cmd/unset/wwv.pl index 6495235f..e7c2286a 100644 --- a/cmd/unset/wwv.pl +++ b/cmd/unset/wwv.pl @@ -18,9 +18,9 @@ foreach $call (@args) { my $user = ($call eq $self->call) ? $self->user : DXUser->get($call); if ($user) { $user->wwv(0); - push @out, DXM::msg('wwvu', $call); + push @out, $self->msg('wwvu', $call); } else { - push @out, DXM::msg('e3', "Unset WWV", $call); + push @out, $self->msg('e3', "Unset WWV", $call); } } return (1, @out); diff --git a/connect/gb7tlh b/connect/gb7tlh index 8cd7be8d..a844b21d 100644 --- a/connect/gb7tlh +++ b/connect/gb7tlh @@ -1,5 +1,6 @@ timeout 15 -connect ax25 ax25_call g1tlh gb7djk -'CONNECTED' 'cluster' -'Connected' '' -client /spider/perl/client.pl gb7tlh ax25 +connect ax25 /usr/sbin/netrom_call bbs gb7djk g1tlh +'Connect' '' +'Connect' 'cluster' +'Connect' +client /usr/bin/perl /spider/perl/client.pl gb7tlh ax25 diff --git a/data/bands.pl b/data/bands.pl index 7ce539d1..7ac51e10 100644 --- a/data/bands.pl +++ b/data/bands.pl @@ -14,6 +14,12 @@ %bands = ( + '73khz' => bless ( { band => [71, 75], + }, 'Bands'), + + '136Khz' => bless ( { band => [135, 138], + }, 'Bands'), + '160m' => bless( { band => [ 1800, 2000 ], cw => [ 1800, 1830 ], rtty => [ 1838, 1841 ], @@ -175,6 +181,7 @@ # %regions = ( + vlf => [ '73khz', '136khz' ], hf => [ '160m', '80m', '40m', '30m', '20m', '17m', '15m', '12m', '10m' ], vhf => [ '6m', '4m', '2m', '220' ], vhfradio => [ 'band1', 'band2' ], diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 3eb387ef..eb306e67 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -61,6 +61,11 @@ use vars qw(%channels %valid); func => '9,Function', loc => '9,Local Vars', # used by func to store local variables in lastread => '9,Last Msg Read', + outbound => '9,outbound?,yesno', + remotecmd => '9,doing rcmd,yesno', + pc34to => '9,last rcmd call', + pc34t => '9,last rcmd time,atime', + pings => '9,out/st pings', ); # create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index aa4cb1a3..8af394b8 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -47,7 +47,7 @@ sub new sub start { - my ($self, $line) = @_; + my ($self, $line, $sort) = @_; my $user = $self->{user}; my $call = $self->{call}; my $name = $user->{name}; @@ -81,7 +81,25 @@ sub start # # This is the normal command prompt driver # + sub normal +{ + my $self = shift; + my $cmdline = shift; + + my @ans = run_cmd($self, $cmdline); + $self->send(@ans) if @ans > 0; + + # send a prompt only if we are in a prompt state + $self->prompt() if $self->{state} =~ /^prompt/o; +} + +# +# this is the thing that runs the command, it is done like this for the +# benefit of remote command execution +# + +sub run_cmd { my $self = shift; my $user = $self->{user}; @@ -141,18 +159,15 @@ sub normal if ($ans[0]) { shift @ans; - $self->send(@ans) if @ans > 0; } else { shift @ans; if (@ans > 0) { - $self->send($self->msg('e2'), @ans); + unshift @ans, $self->msg('e2'); } else { - $self->send($self->msg('e1')); + @ans = $self->msg('e1'); } } - - # send a prompt only if we are in a prompt state - $self->prompt() if $self->{state} =~ /^prompt/o; + return @ans; } # diff --git a/perl/DXCron.pm b/perl/DXCron.pm index c31f4a92..ba200502 100644 --- a/perl/DXCron.pm +++ b/perl/DXCron.pm @@ -61,7 +61,7 @@ sub cread next if /^\s*#/o or /^\s*$/o; my ($min, $hour, $mday, $month, $wday, $cmd) = /^\s*(\w+)\s+(\w+)\s+(\w+)\s+(\w+)\s+(\w+)\s+(.+)$/o; next if !$min; - my $ref = new(); + my $ref = bless {}; my $err; $err |= parse($ref, 'min', $min, 0, 60); diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm index 611df547..ecf4c129 100644 --- a/perl/DXDebug.pm +++ b/perl/DXDebug.pm @@ -34,9 +34,9 @@ sub dbg for (@_) { s/\n$//og; } - my $str = atime . "@_" ; - print "$str\n"; - $fp->writenow($str); + print "@_\n" if defined \*STDOUT; + my $t = time; + $fp->writeunix($t, "$t^@_"); } } diff --git a/perl/DXLog.pm b/perl/DXLog.pm index e4f22803..96b39971 100644 --- a/perl/DXLog.pm +++ b/perl/DXLog.pm @@ -37,7 +37,6 @@ use Julian; use Carp; use strict; - use vars qw($log); $log = new('log', 'dat', 'm'); diff --git a/perl/DXMsg.pm b/perl/DXMsg.pm index 6a6f104a..bbda05cb 100644 --- a/perl/DXMsg.pm +++ b/perl/DXMsg.pm @@ -24,12 +24,14 @@ use FileHandle; use Carp; use strict; -use vars qw(%work @msg $msgdir %valid %busy); +use vars qw(%work @msg $msgdir %valid %busy $maxage $last_clean); %work = (); # outstanding jobs @msg = (); # messages we have %busy = (); # station interlocks $msgdir = "$main::root/msg"; # directory contain the msgs +$maxage = 30 * 86400; # the maximum age that a message shall live for if not marked +$last_clean = 0; # last time we did a clean %valid = ( fromnode => '9,From Node', @@ -51,6 +53,7 @@ $msgdir = "$main::root/msg"; # directory contain the msgs read => '9,Times read', size => '0,Size', msgno => '0,Msgno', + keep => '0,Keep this?,yesno', ); # allocate a new object @@ -170,6 +173,7 @@ sub process add_dir($ref); my $dxchan = DXChannel->get($ref->{to}); $dxchan->send("New mail has arrived for you") if $dxchan; + Log('msg', "Message $ref->{msgno} from $ref->{from} received from $f[2] for $ref->{to}"); } $ref->stop_msg($self); queue_msg(); @@ -184,10 +188,12 @@ sub process my $ref = $work{"$f[2]$f[3]"}; if ($ref) { if ($ref->{private}) { # remove it if it private and gone off site# - $ref->del_msg; + Log('msg', "Message $ref->{msgno} from $ref->{from} sent to $f[2] and deleted"); + $ref->del_msg; } else { - push @{$ref->{gotit}}, $f[2]; # mark this up as being received - $ref->store($ref->{lines}); # re- store the file + Log('msg', "Message $ref->{msgno} from $ref->{from} sent to $f[2]"); + push @{$ref->{gotit}}, $f[2]; # mark this up as being received + $ref->store($ref->{lines}); # re- store the file } $ref->stop_msg($self); } else { @@ -242,6 +248,8 @@ sub process last SWITCH; } } + + clean_old() if $main::systime - $last_clean > 3600 ; # clean the message queue } @@ -320,6 +328,27 @@ sub del_msg dbg('msg', "deleting $self->{msgno}\n"); } +# clean out old messages from the message queue +sub clean_old +{ + my $ref; + + # mark old messages for deletion + foreach $ref (@msg) { + if (!$ref->{keep} && $ref->{t} < $main::systime - $maxage) { + $ref->{deleteme} = 1; + delete $ref->{gotit}; + delete $ref->{list}; + unlink filename($ref->{msgno}); + dbg('msg', "deleting old $ref->{msgno}\n"); + } + } + + # remove them all from the active message list + @msg = map { $_->{deleteme} ? () : $_ } @msg; + $last_clean = $main::systime; +} + # read in a message header sub read_msg_header { diff --git a/perl/DXProt.pm b/perl/DXProt.pm index ab9e0e33..18fafa82 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -55,18 +55,26 @@ sub new # all the crap that comes between). sub start { - my ($self, $line) = shift; - my $call = $self->call; - + my ($self, $line, $sort) = @_; + my $call = $self->{call}; + my $user = $self->{user}; + # remember type of connection $self->{consort} = $line; - + $self->{outbound} = $sort eq 'O'; + $self->{priv} = $user->priv; + $self->{lang} = $user->lang; + $self->{consort} = $line; # save the connection type + $self->{here} = 1; + # set unbuffered $self->send_now('B',"0"); # send initialisation string - $self->send(pc38()) if DXNode->get_all(); - $self->send(pc18()); + if (!$self->{outbound}) { + $self->send(pc38()) if DXNode->get_all(); + $self->send(pc18()); + } $self->state('init'); $self->pc50_t(time); Log('DXProt', "$call connected"); @@ -235,6 +243,13 @@ sub normal # unbusy and stop and outgoing mail (ie if somehow we receive another PC19 without a disconnect) my $mref = DXMsg::get_busy($call); $mref->stop_msg($self) if $mref; + + # add this station to the user database, if required + my $user = DXUser->get_current($call); + $user = DXUser->new($call) if !$user; + $user->node($call) if !$user->node; + $user->sort('A'); + $user->put; } # queue up any messages @@ -279,16 +294,39 @@ sub normal if ($pcno == 25) {last SWITCH;} if (($pcno >= 28 && $pcno <= 33) || $pcno == 40 || $pcno == 42) { # mail/file handling - DXMsg::process($self, $line); - return; + DXMsg::process($self, $line); + return; } if ($pcno == 34 || $pcno == 36) { # remote commands (incoming) - last SWITCH; + if ($field[1] eq $main::mycall) { + if ($self->{priv}) { # you have to have SOME privilege, the commands have further filtering + $self->{remotecmd} = 1; # for the benefit of any command that needs to know + for (DXCommandmode::run_cmd($self, $field[3])) { + s/\s*$//og; + $self->send(pc35($main::mycall, $self->{call}, "$main::mycall:$_")); + } + delete $self->{remotecmd}; + } + } else { + route($field[1], $line); + } + return; } if ($pcno == 35) { # remote command replies - last SWITCH; + if ($field[1] eq $main::mycall) { + my $s = DXChannel::get($main::myalias); + my @ref = grep { $_->pc34to eq $field[2] } DXChannel::get_all(); # people that have rcmded someone + push @ref, $s if $s; + + foreach (@ref) { + $_->send($field[3]); + } + } else { + route($field[1], $line); + } + return; } if ($pcno == 37) {last SWITCH;} @@ -446,7 +484,7 @@ sub send_local_config my @nodes = DXNode::get_all(); # create a list of all the nodes that are not connected to this connection - @nodes = map { $_->dxchan != $self ? $_ : () } @nodes; + @nodes = grep { $_->dxchan != $self } @nodes; $self->send($me->pc19(@nodes)); # get all the users connected on the above nodes and send them out diff --git a/perl/DXProtout.pm b/perl/DXProtout.pm index af833183..555bc0c7 100644 --- a/perl/DXProtout.pm +++ b/perl/DXProtout.pm @@ -199,6 +199,20 @@ sub pc33 return "PC33^$fromnode^$tonode^$stream^"; } +# remote cmd send +sub pc34 +{ + my($fromnode, $tonode, $msg) = @_; + return "PC34^$tonode^$fromnode^$msg^~"; +} + +# remote cmd reply +sub pc35 +{ + my($fromnode, $tonode, $msg) = @_; + return "PC35^$tonode^$fromnode^$msg^~"; +} + # send all the DX clusters I reckon are connected sub pc38 { diff --git a/perl/Messages b/perl/Messages index 34f0576a..4ef03985 100644 --- a/perl/Messages +++ b/perl/Messages @@ -11,10 +11,15 @@ package DXM; %msgs = ( en => { addr => 'Address set to: $_[0]', + already => '$_[0] already connnected', anns => 'Announce flag set on $_[0]', annu => 'Announce flag unset on $_[0]', conother => 'Sorry $_[0] you are connected on another port', concluster => 'Sorry $_[0] you are already connected elsewhere on the cluster', + confail => 'connection to $_[0] failed ($_[1])', + constart => 'connection to $_[0] started', + dx1 => 'Frequency $_[0] not in band [usage: DX freq call comments](see sh/band)', + dx2 => 'Need a callsign [usage: DX freq call comments]', dxs => 'DX Spots flag set on $_[0]', dxu => 'DX Spots flag unset on $_[0]', e1 => 'Invalid command', @@ -35,7 +40,8 @@ package DXM; ok => 'Operation successful', pr => '$_[0] de $main::mycall $main::cldate $main::ztime >', priv => 'Privilege level changed on $_[0]', - prx => '$main::$mycall >', + prx => '$main::mycall >', + shutting => '$main::mycall shutting down...', talks => 'Talk flag set on $_[0]', talku => 'Talk flag unset on $_[0]', wwvs => 'WWV flag set on $_[0]', diff --git a/perl/Spot.pm b/perl/Spot.pm index e53880e1..7fb1c227 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -172,6 +172,7 @@ sub formatl my $t = ztime($dx[2]); my $d = cldate($dx[2]); return sprintf "%8.1f %-11s %s %s %-28.28s%7s>", $dx[0], $dx[1], $d, $t, $dx[3], "<$dx[4]" ; -} +} + 1; diff --git a/perl/client.pl b/perl/client.pl index cff140b2..32271957 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -29,207 +29,369 @@ # search local then perl directories BEGIN { - # root of directory tree for this system - $root = "/spider"; - $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; - - unshift @INC, "$root/perl"; # this IS the right way round! - unshift @INC, "$root/local"; + # root of directory tree for this system + $root = "/spider"; + $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; + + unshift @INC, "$root/perl"; # this IS the right way round! + unshift @INC, "$root/local"; } use Msg; use DXVars; +use DXDebug; +use IO::Socket; +use IPC::Open2; +use FileHandle; use Carp; -$mode = 2; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent -$call = ""; # the callsign being used -@stdoutq = (); # the queue of stuff to send out to the user -$conn = 0; # the connection object for the cluster -$lastbit = ""; # the last bit of an incomplete input line -$mynl = "\n"; # standard terminator -$lasttime = time; # lasttime something happened on the interface -$outqueue = ""; # the output queue length -$buffered = 1; # buffer output -$savenl = ""; # an NL that has been saved from last time - # cease communications sub cease { - my $sendz = shift; - if (defined $conn && $sendz) { - $conn->send_now("Z$call|bye...\n"); - } - STDOUT->flush; - sleep(2); - exit(0); + my $sendz = shift; + if ($conn && $sendz) { + $conn->send_now("Z$call|bye...\n"); + } + $stdout->flush; + kill(15, $pid) if $pid; + sleep(1); + exit(0); } # terminate program from signal sub sig_term { - cease(1); + cease(1); } # terminate a child sub sig_chld { - $SIG{CHLD} = \&sig_chld; - $waitedpid = wait; + $SIG{CHLD} = \&sig_chld; + $waitedpid = wait; } sub setmode { - if ($mode == 1) { - $mynl = "\r"; - } else { - $mynl = "\n"; - } - $/ = $mynl; + if ($mode == 1) { + $mynl = "\r"; + } else { + $mynl = "\n"; + } + $/ = $mynl; } # handle incoming messages sub rec_socket { - my ($con, $msg, $err) = @_; - if (defined $err && $err) { - cease(1); - } - if (defined $msg) { - my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; - - if ($sort eq 'D') { - my $snl = $mynl; - my $newsavenl = ""; - $snl = "" if $mode == 0; - if ($mode == 2 && $line =~ />$/) { - $newsavenl = $snl; - $snl = ' '; - } - $line =~ s/\n/\r/og if $mode == 1; - #my $p = qq($line$snl); - if ($buffered) { - if (length $outqueue >= 128) { - print $outqueue; - $outqueue = ""; - } - $outqueue .= "$savenl$line$snl"; - $lasttime = time; - } else { - print $savenl, $line, $snl;; - } - $savenl = $newsavenl; - } elsif ($sort eq 'M') { - $mode = $line; # set new mode from cluster - setmode(); - } elsif ($sort eq 'B') { - if ($buffered && $outqueue) { - print $outqueue; - $outqueue = ""; - } - $buffered = $line; # set buffered or unbuffered - } elsif ($sort eq 'Z') { # end, disconnect, go, away ..... - cease(0); - } - } - $lasttime = time; + my ($con, $msg, $err) = @_; + if (defined $err && $err) { + cease(1); + } + if (defined $msg) { + my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; + + if ($sort eq 'D') { + my $snl = $mynl; + my $newsavenl = ""; + $snl = "" if $mode == 0; + if ($mode == 2 && $line =~ />$/) { + $newsavenl = $snl; + $snl = ' '; + } + $line =~ s/\n/\r/og if $mode == 1; + #my $p = qq($line$snl); + if ($buffered) { + if (length $outqueue >= 128) { + print $stdout $outqueue; + $outqueue = ""; + } + $outqueue .= "$savenl$line$snl"; + $lasttime = time; + } else { + print $stdout $savenl, $line, $snl;; + } + $savenl = $newsavenl; + } elsif ($sort eq 'M') { + $mode = $line; # set new mode from cluster + setmode(); + } elsif ($sort eq 'B') { + if ($buffered && $outqueue) { + print $stdout $outqueue; + $outqueue = ""; + } + $buffered = $line; # set buffered or unbuffered + } elsif ($sort eq 'Z') { # end, disconnect, go, away ..... + cease(0); + } + } + $lasttime = time; } sub rec_stdin { - my ($fh) = @_; - my $buf; - my @lines; - my $r; - my $first; - my $dangle = 0; - - $r = sysread($fh, $buf, 1024); -# print "sys: $r $buf"; - if ($r > 0) { - if ($mode) { - $buf =~ s/\r/\n/og if $mode == 1; - $dangle = !($buf =~ /\n$/); - if ($buf eq "\n") { - @lines = (" "); - } else { - @lines = split /\n/, $buf; - } - if ($dangle) { # pull off any dangly bits - $buf = pop @lines; - } else { - $buf = ""; - } - $first = shift @lines; - unshift @lines, ($lastbit . $first) if ($first); - foreach $first (@lines) { - $conn->send_now("D$call|$first"); - } - $lastbit = $buf; - $savenl = ""; # reset savenl 'cos we will have done a newline on input + my ($fh) = @_; + my $buf; + my @lines; + my $r; + my $first; + my $dangle = 0; + + $r = sysread($fh, $buf, 1024); + # my $prbuf; + # $prbuf = $buf; + # $prbuf =~ s/\r/\\r/; + # $prbuf =~ s/\n/\\n/; + # print "sys: $r ($prbuf)\n"; + if ($r > 0) { + if ($mode) { + $buf =~ s/\r/\n/og if $mode == 1; + $dangle = !($buf =~ /\n$/); + if ($buf eq "\n") { + @lines = (" "); + } else { + @lines = split /\n/, $buf; + } + if ($dangle) { # pull off any dangly bits + $buf = pop @lines; + } else { + $buf = ""; + } + $first = shift @lines; + unshift @lines, ($lastbit . $first) if ($first); + foreach $first (@lines) { + # print "send_now $call $first\n"; + $conn->send_now("D$call|$first"); + } + $lastbit = $buf; + $savenl = ""; # reset savenl 'cos we will have done a newline on input + } else { + $conn->send_now("D$call|$buf"); + } + } elsif ($r == 0) { + cease(1); + } + $lasttime = time; +} + +sub doconnect +{ + my ($sort, $line) = @_; + dbg('connect', "CONNECT sort: $sort command: $line"); + if ($sort eq 'telnet') { + # this is a straight network connect + my ($host) = $line =~ /host\s+(\w+)/o; + my ($port) = $line =~ /port\s+(\d+)/o; + $port = 23 if !$port; + + $sock = IO::Socket::INET->new(PeerAddr => "$host", PeerPort => "$port", Proto => 'tcp') + or die "Can't connect to $host port $port $!"; + + } elsif ($sort eq 'ax25') { + my @args = split /\s+/, $line; + $rfh = new FileHandle; + $wfh = new FileHandle; + $pid = open2($rfh, $wfh, "$line") or die "can't do $line $!"; + dbg('connect', "got pid $pid"); + $wfh->autoflush(1); } else { - $conn->send_now("D$call|$buf"); + die "invalid type of connection ($sort)"; } - } elsif ($r == 0) { - cease(1); - } - $lasttime = time; + $csort = $sort; +} + +sub doabort +{ + my $string = shift; + dbg('connect', "abort $string"); + $abort = $string; } +sub dotimeout +{ + my $val = shift; + dbg('connect', "timeout set to $val"); + $timeout = $val; +} + +sub dochat +{ + my ($expect, $send) = @_; + dbg('connect', "CHAT \"$expect\" -> \"$send\""); + my $line; + + # alarm($timeout); + + if ($expect) { + if ($csort eq 'telnet') { + $line = <$sock>; + chomp; + } elsif ($csort eq 'ax25') { + local $/ = "\r"; + $line = <$rfh>; + $line =~ s/\r//og; + } + dbg('connect', "received \"$line\""); + if ($abort && $line =~ /$abort/i) { + dbg('connect', "aborted on /$abort/"); + cease(11); + } + } + if ($send && (!$expect || $line =~ /$expect/i)) { + if ($csort eq 'telnet') { + $sock->print("$send\n"); + } elsif ($csort eq 'ax25') { + local $\ = "\r"; + $wfh->print("$send\r"); + } + dbg('connect', "sent \"$send\""); + } +} + +sub timeout +{ + dbg('connect', "timed out after $timeout seconds"); + cease(10); +} + + +# +# initialisation +# + +$mode = 2; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent +$call = ""; # the callsign being used +@stdoutq = (); # the queue of stuff to send out to the user +$conn = 0; # the connection object for the cluster +$lastbit = ""; # the last bit of an incomplete input line +$mynl = "\n"; # standard terminator +$lasttime = time; # lasttime something happened on the interface +$outqueue = ""; # the output queue length +$buffered = 1; # buffer output +$savenl = ""; # an NL that has been saved from last time +$timeout = 30; # default timeout for connects +$abort = ""; # the current abort string +$cpath = "$root/connect"; # the basic connect directory + +$pid = 0; # the pid of the child program +$csort = ""; # the connection type +$sock = 0; # connection socket + +$stdin = *STDIN; +$stdout = *STDOUT; +$rfh = 0; +$wfh = 0; + + +# +# deal with args +# + $call = uc shift @ARGV; $call = uc $myalias if !$call; $connsort = lc shift @ARGV; $connsort = 'local' if !$connsort; -$mode = ($connsort =~ /^ax/o) ? 1 : 2; - -# is this an out going connection? -if ($ARGV[0] eq "connect") { - shift @ARGV; # lose the keyword - -} +$mode = ($connsort =~ /^ax/o) ? 1 : 2; setmode(); + if ($call eq $mycall) { - print "You cannot connect as your cluster callsign ($mycall)", $nl; - cease(0); + print $stdout "You cannot connect as your cluster callsign ($mycall)", $nl; + cease(0); } -#select STDOUT; $| = 1; -STDOUT->autoflush(1); +$stdout->autoflush(1); $SIG{'INT'} = \&sig_term; $SIG{'TERM'} = \&sig_term; -$SIG{'HUP'} = \&sig_term; +$SIG{'HUP'} = 'IGNORE'; $SIG{'CHLD'} = \&sig_chld; +dbgadd('connect'); + +# is this an out going connection? +if ($connsort eq "connect") { + my $mcall = lc $call; + + open(IN, "$cpath/$mcall") or cease(2); + @in = ; + close IN; + + # alarm($timeout); + + for (@in) { + chomp; + next if /^\s*\#/o; + next if /^\s*$/o; + doconnect($1, $2) if /^\s*co\w*\s+(\w+)\s+(.*)$/io; + doabort($1) if /^\s*a\w*\s+(.*)/io; + dotimeout($1) if /^\s*t\w*\s+(\d+)/io; + dochat($1, $2) if /\s*\'(.*)\'\s+\'(.*)\'/io; + } + + dbg('connect', "Connected to $call, starting normal protocol"); + dbgsub('connect'); + + # if we get here we are connected + if ($csort eq 'ax25') { + # open(STDIN, "<&R"); + # open(STDOUT, ">&W"); + # close R; + # close W; + $stdin = $rfh; + $stdout = $wfh; + } elsif ($csort eq 'telnet') { + # open(STDIN, "<&$sock"); + # open(STDOUT, ">&$sock"); + # close $sock; + $stdin = $sock; + $stdout = $sock; + } + alarm(0); + $outbound = 1; + $connsort = $csort; + $stdout->autoflush(1); + close STDIN; + close STDOUT; + close STDERR; + + + $mode = ($connsort =~ /^ax/o) ? 1 : 2; + setmode(); +} + +setmode(); + $conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket); if (! $conn) { - if (-r "$data/offline") { - open IN, "$data/offline" or die; - while () { - s/\n/\r/og if $mode == 1; - print; + if (-r "$data/offline") { + open IN, "$data/offline" or die; + while () { + s/\n/\r/og if $mode == 1; + print $stdout; + } + close IN; + } else { + print $stdout "Sorry, the cluster $mycall is currently off-line", $mynl; } - close IN; - } else { - print "Sorry, the cluster $mycall is currently off-line", $mynl; - } - cease(0); + cease(0); } -$conn->send_now("A$call|$connsort"); -Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin); +$let = $outbound ? 'O' : 'A'; +$conn->send_now("$let$call|$connsort"); +Msg->set_event_handler($stdin, "read" => \&rec_stdin); for (;;) { - my $t; - Msg->event_loop(1, 0.010); - $t = time; - if ($t > $lasttime) { - if ($outqueue) { - print $outqueue; - $outqueue = ""; + my $t; + Msg->event_loop(1, 0.010); + $t = time; + if ($t > $lasttime) { + if ($outqueue) { + print $stdout $outqueue; + $outqueue = ""; + } + $lasttime = $t; } - $lasttime = $t; - } } diff --git a/perl/cluster.pl b/perl/cluster.pl index 848131f7..8e888842 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -47,7 +47,7 @@ package main; @inqueue = (); # the main input queue, an array of hashes $systime = 0; # the time now (in seconds) -$version = 1.4; # the version no of the software +$version = 1.5; # the version no of the software # handle disconnections sub disconnect @@ -133,6 +133,12 @@ sub cease exit(0); } +# the reaper of children +sub reap +{ + my $cpid = wait; +} + # this is where the input queue is dealt with and things are dispatched off to other parts of # the cluster sub process_inqueue @@ -142,15 +148,15 @@ sub process_inqueue my $data = $self->{data}; my $dxchan = $self->{dxchan}; - my ($sort, $call, $line) = $data =~ /^(\w)(\S+)\|(.*)$/; + my ($sort, $call, $line) = $data =~ /^(\w)(\w+)\|(.*)$/; # do the really sexy console interface bit! (Who is going to do the TK interface then?) dbg('chan', "<- $sort $call $line\n"); # handle A records my $user = $dxchan->user; - if ($sort eq 'A') { - $dxchan->start($line); + if ($sort eq 'A' || $sort eq 'O') { + $dxchan->start($line, $sort); } elsif ($sort eq 'D') { die "\$user not defined for $call" if !defined $user; @@ -171,6 +177,8 @@ sub process_inqueue # ############################################################# +$systime = time; + # open the debug file, set various FHs to be unbuffered foreach (@debug) { dbgadd($_); @@ -202,6 +210,7 @@ Msg->new_server("$clusteraddr", $clusterport, \&login); $SIG{'INT'} = \&cease; $SIG{'TERM'} = \&cease; $SIG{'HUP'} = 'IGNORE'; +$SIG{'CHLD'} = \&reap; # read in system messages DXM->init(); @@ -221,9 +230,10 @@ Spot->init(); # put in a DXCluster node for us here so we can add users and take them away DXNode->new(0, $mycall, 0, 1, $DXProt::myprot_version); -# read in any existing message headers +# read in any existing message headers and clean out old crap print "reading existing message headers\n"; DXMsg->init(); +DXMsg::clean_old(); # read in any cron jobs print "reading cron jobs\n"; @@ -247,6 +257,9 @@ for (;;) { DXProt::process(); # process ongoing ak1a pcxx stuff DXConnect::process(); } + if ($decease) { + last if --$decease <= 0; + } } diff --git a/perl/connect.pl b/perl/connect.pl index f50c89dd..590660fa 100755 --- a/perl/connect.pl +++ b/perl/connect.pl @@ -28,66 +28,182 @@ # search local then perl directories BEGIN { - # root of directory tree for this system - $root = "/spider"; - $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; - - unshift @INC, "$root/perl"; # this IS the right way round! - unshift @INC, "$root/local"; + # root of directory tree for this system + $root = "/spider"; + $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; + + unshift @INC, "$root/perl"; # this IS the right way round! + unshift @INC, "$root/local"; } use DXVars; use IO::Socket; -use POSIX; +use FileHandle; +use Open2; +use DXDebug; +use POSIX qw(dup); use Carp; -$timeout = 30; # default timeout for each stage of the connect -$abort = ''; # default connection abort string -$path = "$root/connect"; # the basic connect directory -$client = "$root/perl/client.pl"; # default client +$timeout = 30; # default timeout for each stage of the connect +$abort = ''; # default connection abort string +$path = "$root/connect"; # the basic connect directory +$client = "$root/perl/client.pl"; # default client + +$connected = 0; # we have successfully connected or started an interface program +$pid = 0; # the pid of the child program +$csort = ""; # the connection type +$sock = 0; # connection socket -$connected = 0; # we have successfully connected or started an interface program +sub timeout; +sub term; +sub reap; -exit(1) if !$ARGV[0]; # bang out if no callsign +$SIG{ALRM} = \&timeout; +$SIG{TERM} = \&term; +$SIG{INT} = \&term; +$SIG{REAP} = \&reap; +$SIG{HUP} = 'IGNORE'; + +exit(1) if !$ARGV[0]; # bang out if no callsign open(IN, "$path/$ARGV[0]") or exit(2); +@in = ; +close IN; +STDOUT->autoflush(1); +dbgadd('connect'); + +alarm($timeout); -while () { - chomp; - next if /^\s*#/o; - next if /^\s*$/o; - doconnect($1, $2) if /^\s*co\w*\s+(.*)$/io; - doclient($1) if /^\s*cl\w*\s+(.*)$/io; - doabort($1) if /^\s*a\w*\s+(.*)/io; - dotimeout($1) if /^\s*t\w*\s+(\d+)/io; - dochat($1, $2) if /\s*\'(.*)\'\s+\'(.*)'/io; +for (@in) { + chomp; + next if /^\s*\#/o; + next if /^\s*$/o; + doconnect($1, $2) if /^\s*co\w*\s+(\w+)\s+(.*)$/io; + doclient($1) if /^\s*cl\w*\s+(\w+)\s+(.*)$/io; + doabort($1) if /^\s*a\w*\s+(.*)/io; + dotimeout($1) if /^\s*t\w*\s+(\d+)/io; + dochat($1, $2) if /\s*\'(.*)\'\s+\'(.*)\'/io; } sub doconnect { - my ($sort, $name) = @_; - print "connect $sort $name\n"; + my ($sort, $line) = @_; + dbg('connect', "CONNECT sort: $sort command: $line"); + if ($sort eq 'net') { + # this is a straight network connect + my ($host) = $line =~ /host\s+(\w+)/o; + my ($port) = $line =~ /port\s+(\d+)/o; + $port = 23 if !$port; + + $sock = IO::Socket::INET->new(PeerAddr => "$host", PeerPort => "$port", Proto => 'tcp') + or die "Can't connect to $host port $port $!"; + + } elsif ($sort eq 'ax25') { + my @args = split /\s+/, $line; + $pid = open2(\*R, \*W, "$line") or die "can't do $line $!"; + dbg('connect', "got pid $pid"); + W->autoflush(1); + } else { + die "can't get here"; + } + $csort = $sort; } sub doabort { - my $string = shift; - print "abort $string\n"; + my $string = shift; + dbg('connect', "abort $string"); + $abort = $string; } sub dotimeout { - my $val = shift; - print "timeout $val\n"; + my $val = shift; + dbg('connect', "timeout set to $val"); + alarm($timeout = $val); } sub dochat { - my ($expect, $send) = @_; - print "chat '$expect' '$send'\n"; + my ($expect, $send) = @_; + dbg('connect', "CHAT \"$expect\" -> \"$send\""); + my $line; + + alarm($timeout); + + if ($expect) { + if ($csort eq 'net') { + $line = <$sock>; + chomp; + } elsif ($csort eq 'ax25') { + local $/ = "\r"; + $line = ; + $line =~ s/\r//og; + } + dbg('connect', "received \"$line\""); + if ($abort && $line =~ /$abort/i) { + dbg('connect', "aborted on /$abort/"); + exit(11); + } + } + if ($send && (!$expect || $line =~ /$expect/i)) { + if ($csort eq 'net') { + $sock->print("$send\n"); + } elsif ($csort eq 'ax25') { + local $\ = "\r"; + W->print("$send\r"); + } + dbg('connect', "sent \"$send\""); + } } sub doclient { - my $cl = shift; - print "client $cl\n"; + my ($cl, $args) = @_; + dbg('connect', "client: $cl args: $args"); + my @args = split /\s+/, $args; + +# if (!defined ($pid = fork())) { +# dbg('connect', "can't fork"); +# exit(13); +# } +# if ($pid) { +# sleep(1); +# exit(0); +# } else { + + close(STDIN); + close(STDOUT); + if ($csort eq 'net') { + open STDIN, "<&$sock"; + open STDOUT, ">&$sock"; + exec $cl, @args; + } elsif ($csort eq 'ax25') { + open STDIN, "<&R"; + open STDOUT, ">&W"; + exec $cl, @args; + } else { + dbg('connect', "client can't get here"); + exit(13); + } +# } +} + +sub timeout +{ + dbg('connect', "timed out after $timeout seconds"); + exit(10); +} + +sub term +{ + dbg('connect', "caught INT or TERM signal"); + kill $pid if $pid; + sleep(2); + exit(12); +} + +sub reap +{ + my $wpid = wait; + dbg('connect', "pid $wpid has died"); } -- 2.43.0