fixed problems with show/channel

made a start on the pc protocol stuff
added buffering to the client

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.
 

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;

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);

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;
+  my $call = $self->{call};
+  my $line;
 
-    foreach $line (@_) {
-	  chomp $line;
-	  dbg('chan', "-> D $call $line\n");
-	  $conn->send_later("D$call|$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)

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);
+	}
+  }
 }
 
 #

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 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__ 

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;
 

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;
   }
 }

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
 }