],
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 => [
],
#
my $self = shift;
-return if $self->priv < 9;
+return (0) if $self->priv < 9;
$DB::single = 1;
$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};
}
}
-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;
}
my @out;
my @body;
my $ref;
+my $call = $self->call;
# $DB::single = 1;
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";
}
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
}
$user->addr($line);
-push @out, DXM::msg('addr', $call, $line);
+push @out, $self->msg('addr', $call, $line);
return (1, @out);
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);
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);
}
}
$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);
}
}
}
my $priv = shift @args;
my @out;
my $user;
-
-$DB::single = 1;
+my $ref;
return (0) if $self->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);
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);
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);
# $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);
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);
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);
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);
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);
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);
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
%bands = (
+ '73khz' => bless ( { band => [71, 75],
+ }, 'Bands'),
+
+ '136Khz' => bless ( { band => [135, 138],
+ }, 'Bands'),
+
'160m' => bless( { band => [ 1800, 2000 ],
cw => [ 1800, 1830 ],
rtty => [ 1838, 1841 ],
#
%regions = (
+ vlf => [ '73khz', '136khz' ],
hf => [ '160m', '80m', '40m', '30m', '20m', '17m', '15m', '12m', '10m' ],
vhf => [ '6m', '4m', '2m', '220' ],
vhfradio => [ 'band1', 'band2' ],
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)]
sub start
{
- my ($self, $line) = @_;
+ my ($self, $line, $sort) = @_;
my $user = $self->{user};
my $call = $self->{call};
my $name = $user->{name};
#
# 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};
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;
}
#
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);
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^@_");
}
}
use Carp;
use strict;
-
use vars qw($log);
$log = new('log', 'dat', 'm');
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',
read => '9,Times read',
size => '0,Size',
msgno => '0,Msgno',
+ keep => '0,Keep this?,yesno',
);
# allocate a new object
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();
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 {
last SWITCH;
}
}
+
+ clean_old() if $main::systime - $last_clean > 3600 ; # clean the message queue
}
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
{
# 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");
# 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
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;}
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
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
{
%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',
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]',
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;
# 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 = <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 (<IN>) {
- s/\n/\r/og if $mode == 1;
- print;
+ if (-r "$data/offline") {
+ open IN, "$data/offline" or die;
+ while (<IN>) {
+ 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;
- }
}
@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
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
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;
#
#############################################################
+$systime = time;
+
# open the debug file, set various FHs to be unbuffered
foreach (@debug) {
dbgadd($_);
$SIG{'INT'} = \&cease;
$SIG{'TERM'} = \&cease;
$SIG{'HUP'} = 'IGNORE';
+$SIG{'CHLD'} = \&reap;
# read in system messages
DXM->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";
DXProt::process(); # process ongoing ak1a pcxx stuff
DXConnect::process();
}
+ if ($decease) {
+ last if --$decease <= 0;
+ }
}
# 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 = <IN>;
+close IN;
+STDOUT->autoflush(1);
+dbgadd('connect');
+
+alarm($timeout);
-while (<IN>) {
- 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 = <R>;
+ $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");
}
projects / spider.git / commitdiff