From 20b0104deaeab77fa7ab1444dbcedfcdbf5865f8 Mon Sep 17 00:00:00 2001 From: djk Date: Sun, 21 Jun 1998 21:17:02 +0000 Subject: [PATCH] fixed problems with show/channel made a start on the pc protocol stuff added buffering to the client --- cmd/Notes.txt | 5 ++++ cmd/help.hlp | 0 cmd/help.pl | 0 cmd/show/channel.pl | 5 ++-- cmd/show/users.pl | 15 ++++++++++ perl/DXChannel.pm | 58 ++++++++++++++----------------------- perl/DXCommandmode.pm | 13 +++++++++ perl/DXProt.pm | 66 +++++++++++++++++++++++++++++++++++++++---- perl/DXVars.pm | 11 ++++++-- perl/client.pl | 47 ++++++++++++++++++++++++------ perl/cluster.pl | 22 +++++++++------ 11 files changed, 178 insertions(+), 64 deletions(-) create mode 100644 cmd/help.hlp create mode 100644 cmd/help.pl diff --git a/cmd/Notes.txt b/cmd/Notes.txt index 16b2a25c..fb3b303a 100644 --- a/cmd/Notes.txt +++ b/cmd/Notes.txt @@ -97,6 +97,11 @@ Programming Notes ($Id$) locators show/locator gb7dxc - bearing and distance to gb7dxc if poss. +* It is important that you remember when you have tie hashes using MLDBM + et al. If you do a DXUser->get($call) you will get a different (older) + thing than the one in $self->$user. This is almost certainly NOT what + you want if want to modify a user that is currently connected. + * Anything you output with a > as the last character is taken to mean that this is a prompt and will not have a \r or \n appended to it. diff --git a/cmd/help.hlp b/cmd/help.hlp new file mode 100644 index 00000000..e69de29b diff --git a/cmd/help.pl b/cmd/help.pl new file mode 100644 index 00000000..e69de29b diff --git a/cmd/show/channel.pl b/cmd/show/channel.pl index e1ef7610..147c150a 100644 --- a/cmd/show/channel.pl +++ b/cmd/show/channel.pl @@ -4,9 +4,10 @@ # $Id$ # +use strict; my ($self, $line) = @_; -my @list = /\s+/, $line; # generate a list of callsigns -@list = ($self->call) if (!@list || $self->priv < 9); # my channel if no callsigns +my @list = split /\s+/, $line; # generate a list of callsigns +@list = ($self->call) if !@list || $self->priv < 9; # my channel if no callsigns my $call; my @out; diff --git a/cmd/show/users.pl b/cmd/show/users.pl index e69de29b..2e69786b 100644 --- a/cmd/show/users.pl +++ b/cmd/show/users.pl @@ -0,0 +1,15 @@ +# +# show either the current user or a nominated set +# +# $Id$ +# + +my ($self, $line) = @_; +my @list = DXChannel->get_all(); +my $chan; +my @out; +foreach $chan (@list) { + push @out, "Callsign: $chan->{call}"; +} + +return (1, @out); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 36a84aa1..24b87566 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -36,13 +36,15 @@ use DXDebug; call => '0,Callsign', conn => '9,Msg Conn ref', user => '9,DXUser ref', - t => '0,Time,atime', + startt => '0,Start Time,atime', + t => '9,Time,atime', priv => '9,Privilege', state => '0,Current State', oldstate => '5,Last State', list => '9,Dep Chan List', name => '0,User Name', - consort => '9,Connection Type' + consort => '9,Connection Type', + sort => '9,Type of Channel', ); @@ -56,7 +58,7 @@ sub new $self->{call} = $call; $self->{conn} = $conn if defined $conn; # if this isn't defined then it must be a list $self->{user} = $user if defined $user; - $self->{t} = time; + $self->{startt} = $self->{t} = time; $self->{state} = 0; $self->{oldstate} = 0; bless $self, $pkg; @@ -103,25 +105,16 @@ sub send_now { my $self = shift; my $conn = $self->{conn}; - - # is this a list of channels ? - if (!defined $conn) { - die "tried to send_now to an invalid channel list" if !defined $self->{list}; - my $lself; - foreach $lself (@$self->{list}) { - $lself->send_now(@_); # it's recursive :-) - } - } else { - my $sort = shift; - my $call = $self->{call}; - my $line; + my $sort = shift; + my $call = $self->{call}; + my $line; - foreach $line (@_) { - chomp $line; - dbg('chan', "-> $sort $call $line\n"); - $conn->send_now("$sort$call|$line"); - } + foreach $line (@_) { + chomp $line; + dbg('chan', "-> $sort $call $line\n"); + $conn->send_now("$sort$call|$line"); } + $self->{t} = time; } # @@ -131,24 +124,15 @@ sub send # this is always later and always data { my $self = shift; my $conn = $self->{conn}; - - # is this a list of channels ? - if (!defined $conn) { - die "tried to send to an invalid channel list" if !defined $self->{list}; - my $lself; - foreach $lself (@$self->{list}) { - $lself->send(@_); # here as well :-) :-) - } - } else { - my $call = $self->{call}; - my $line; - - foreach $line (@_) { - chomp $line; - dbg('chan', "-> D $call $line\n"); - $conn->send_later("D$call|$line"); - } + my $call = $self->{call}; + my $line; + + foreach $line (@_) { + chomp $line; + dbg('chan', "-> D $call $line\n"); + $conn->send_later("D$call|$line"); } + $self->{t} = time; } # send a file (always later) diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 2ae7a060..d48de1c8 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -42,6 +42,7 @@ sub start $self->{priv} = $user->priv; $self->{priv} = 0 if $line =~ /^(ax|te)/; # set the connection priv to 0 - can be upgraded later $self->{consort} = $line; # save the connection type + $self->sort('U'); # set the channel type } # @@ -92,7 +93,19 @@ sub normal # sub process { + my $t = time; + my @chan = DXChannel->get_all(); + my $chan; + + foreach $chan (@chan) { + next if $chan->sort ne 'U'; + # send a prompt if no activity out on this channel + if ($t >= $chan->t + $main::user_interval) { + $chan->prompt() if $chan->{state} =~ /^prompt/o; + $chan->t($t); + } + } } # diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 1f224766..88fed5e3 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -11,6 +11,8 @@ package DXProt; @ISA = qw(DXChannel); +use strict; + use DXUtil; use DXChannel; use DXUser; @@ -25,9 +27,15 @@ sub start my $self = shift; my $call = $self->call; + # set the channel sort + $self->sort('A'); + + # set unbuffered + self->send_now('B',"0"); + # do we have him connected on the cluster somewhere else? - $self->pc38(); - $self->pc18(); + $self->send(pc38()); + $self->send(pc18()); $self->{state} = 'incoming'; } @@ -45,7 +53,19 @@ sub normal # sub process { - + my $t = time; + my @chan = DXChannel->get_all(); + my $chan; + + foreach $chan (@chan) { + next if $chan->sort ne 'A'; + + # send a pc50 out on this channel + if ($t >= $chan->t + $main::pc50_interval) { + $chan->send(pc50()); + $chan->t($t); + } + } } # @@ -57,19 +77,53 @@ sub finish } # -# All the various PC routines +# some active measures # -sub pc18 +sub broadcast { + my $s = shift; + $s = shift if ref $s; # if I have been called $self-> ignore it. + my @except = @_; # to all channels EXCEPT these (dxchannel refs) + my @chan = DXChannel->get_all(); + my ($chan, $except); + +L: foreach $chan (@chan) { + next if $chan->sort != 'A'; # only interested in ak1a channels + foreach $except (@except) { + next L if $except == $chan; # ignore channels in the 'except' list + } + chan->send($s); # send it + } +} +# +# All the PCxx generation routines +# + +sub pc18 +{ + return "PC18^wot a load of twaddle^$main::myprot_version^~"; } +# send all the DX clusters I reckon are connected sub pc38 { - + my @list = DXNode->get_all(); + my $list; + my @nodes; + + foreach $list (@list) { + push @nodes, $list->call; + } + return "PC38^" . join(',', @nodes) . "^~"; } +sub pc50 +{ + my $n = DXUsers->count; + return "PC50^$main::mycall^$n^H99^"; +} 1; __END__ diff --git a/perl/DXVars.pm b/perl/DXVars.pm index 5baf3a67..362f26e2 100644 --- a/perl/DXVars.pm +++ b/perl/DXVars.pm @@ -13,10 +13,11 @@ require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw($mycall $myname $myalias $mylatitude $mylongtitude $mylocator - $myqth $myemail $myprot + $myqth $myemail $myprot_version $clusterport $clusteraddr $debugfn $def_hopcount $root $data $system $cmd $userfn $motd $local_cmd $mybbsaddr + $pc50_interval, $user_interval ); @@ -57,7 +58,7 @@ $clusterport = 27754; $debugfn = "/tmp/debug_cluster"; # the version of DX cluster (tm) software I am masquerading as -$myprot = "5447"; +$myprot_version = "5447"; # your favorite way to say 'Yes' $yes = 'Yes'; @@ -65,6 +66,12 @@ $yes = 'Yes'; # your favorite way to say 'No' $no = 'No'; +# the interval between pc50s (in seconds) +$pc50_interval = 14*60; + +# the interval between unsolicited prompts if not traffic +$user_interval = 11*60; + # default hopcount to use - note this will override any incoming hop counts, if they are greater $def_hopcount = 7; diff --git a/perl/client.pl b/perl/client.pl index c5b4bbec..f44120f2 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -12,9 +12,10 @@ # $Id$ # +# search local then perl directories BEGIN { + unshift @INC, "/spider/perl"; # this IS the right way round! unshift @INC, "/spider/local"; - unshift @INC, "/spider/perl"; } use Msg; @@ -26,6 +27,10 @@ $call = ""; # the callsign being used $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 @@ -65,18 +70,39 @@ sub rec_socket if ($sort eq 'D') { my $snl = $mynl; + my $newsavenl = ""; $snl = "" if $mode == 0; - $snl = ' ' if ($mode && $line =~ />$/); + if ($mode && $line =~ />$/) { + $newsavenl = $snl; + $snl = ' '; + } $line =~ s/\n/\r/og if $mode == 1; #my $p = qq($line$snl); - print $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; } sub rec_stdin @@ -105,13 +131,15 @@ sub rec_stdin foreach $first (@lines) { $conn->send_now("D$call|$first"); } - $lastbit = $buf; + $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; } $call = uc shift @ARGV; @@ -132,14 +160,15 @@ $conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket); $conn->send_now("A$call|$connsort"); Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin); -$lasttime = time; for (;;) { my $t; Msg->event_loop(1, 0.010); $t = time; - if (t > $lasttime+660 && $connsort =~ /^ax/o) { # every e - print pack('xx'); - STDOUT->fflush(); + if ($t > $lasttime) { + if ($outqueue) { + print $outqueue; + $outqueue = ""; + } $lasttime = $t; } } diff --git a/perl/cluster.pl b/perl/cluster.pl index 79c5b5c8..76dea219 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -1,17 +1,21 @@ #!/usr/bin/perl # -# A thing that implements dxcluster 'protocol' +# This is the DX cluster 'daemon'. It sits in the middle of its little +# web of client routines sucking and blowing data where it may. # -# This is a perl module/program that sits on the end of a dxcluster -# 'protocol' connection and deals with anything that might come along. -# -# this program is called by ax25d and gets raw ax25 text on its input +# Hence the name of 'spider' (although it may become 'dxspider') # # Copyright (c) 1998 Dirk Koopman G1TLH # # $Id$ # +# make sure that modules are searched in the order local then perl +BEGIN { + unshift @INC, '/spider/perl'; # this IS the right way round! + unshift @INC, '/spider/local'; +} + use Msg; use DXVars; use DXUtil; @@ -176,13 +180,15 @@ for (;;) { my $timenow; Msg->event_loop(1, 0.001); $timenow = time; + process_inqueue(); # read in lines from the input queue and despatch them + + # do timed stuff, ongoing processing happens one a second if ($timenow != $systime) { $systime = $timenow; $cldate = &cldate(); $ztime = &ztime(); + DXCommandmode::process(); # process ongoing command mode stuff + DXProt::process(); # process ongoing ak1a pcxx stuff } - process_inqueue(); # read in lines from the input queue and despatch them - DXCommandmode::process(); # process ongoing command mode stuff - DXProt::process(); # process ongoing ak1a pcxx stuff } -- 2.34.1