Hardened up the cluster->client link in the cluster software so that

rubbish on port 27754 doesn't (usually) crash the cluster.

diff --git a/Changes b/Changes
index 32d3844b245333f40c3a2385042f5612c3acd170..a71063c40a1ffa93d063735719b080093791b27d 100644 (file)
--- a/Changes
+++ b/Changes
@@ -4,6 +4,8 @@
 3. added update_sysop.pl which cleans out all previous versions of the sysops
 information from the user database and recreates it with that in DXVars.pm
 4. Added node type to links and who
 3. added update_sysop.pl which cleans out all previous versions of the sysops
 information from the user database and recreates it with that in DXVars.pm
 4. Added node type to links and who

+5. Hardened up the cluster->client link in the cluster software so that 
+rubbish on port 27754 doesn't (usually) crash the cluster.

 14Jun00=======================================================================
 1. fixed sh/node crash
 2. fixed RTT in who.pl
 14Jun00=======================================================================
 1. fixed sh/node crash
 2. fixed RTT in who.pl

diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm
index 3637b7626885a6ec63e20720c8b3008ba03ba270..df74bfc89302fdf00f398735bd53df5b5985a546 100644 (file)
--- a/perl/DXChannel.pm
+++ b/perl/DXChannel.pm
@@ -436,6 +436,26 @@ sub field_prompt
        return $valid{$ele};
 }
 
        return $valid{$ele};
 }
 

+# take a standard input message and decode it into its standard parts
+sub decode_input
+{
+       my $dxchan = shift;
+       my $data = shift;
+       my ($sort, $call, $line) = $data =~ /^([A-Z])([A-Z1-9\-]{3,9})\|(.*)$/;
+
+       my $chcall = (ref $dxchan) ? $dxchan->call : "UN.KNOWN";
+       
+       # the above regexp must work
+       if (!defined $sort || !defined $call || !defined  $line ||
+                  (ref $dxchan && $call ne $chcall)) {
+               $data =~ s/([\x00-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
+               dbg('chan', "DUFF Line from $chcall: $data");
+               return ();
+       }
+       
+       return ($sort, $call, $line);
+}
+

 no strict;
 sub AUTOLOAD
 {
 no strict;
 sub AUTOLOAD
 {

diff --git a/perl/cluster.pl b/perl/cluster.pl
index d026edd66617667bfeaf1010b07b5aaac83606cd..4da018b0bfd25b8d6b2d55e407288a923acffc62 100755 (executable)
--- a/perl/cluster.pl
+++ b/perl/cluster.pl
@@ -120,7 +120,8 @@ sub rec
        
        # set up the basic channel info - this needs a bit more thought - there is duplication here
        if (!defined $dxchan) {
        
        # set up the basic channel info - this needs a bit more thought - there is duplication here
        if (!defined $dxchan) {

-               my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
+               my ($sort, $call, $line) = DXChannel::decode_input(0, $msg);
+               return unless defined $sort;

  
                # is there one already connected to me - locally? 
                my $user = DXUser->get($call);
  
                # is there one already connected to me - locally? 
                my $user = DXUser->get($call);


@@ -246,17 +247,15 @@ sub process_inqueue
        
        my $data = $self->{data};
        my $dxchan = $self->{dxchan};
        
        my $data = $self->{data};
        my $dxchan = $self->{dxchan};

-       my ($sort, $call, $line) = $data =~ /^(\w)([^\|]+)\|(.*)$/;

        my $error;
        my $error;

-       
-       # the above regexp must work
-       return unless ($sort && $call && $line);
+       my ($sort, $call, $line) = DXChannel::decode_input($dxchan, $data);
+       return unless defined $sort;

        
        # translate any crappy characters into hex characters 
        if ($line =~ /[\x00-\x06\x08\x0a-\x1f\x7f-\xff]/o) {
                $line =~ s/([\x00-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
        }
        
        # translate any crappy characters into hex characters 
        if ($line =~ /[\x00-\x06\x08\x0a-\x1f\x7f-\xff]/o) {
                $line =~ s/([\x00-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
        }

-       
+

        # do the really sexy console interface bit! (Who is going to do the TK interface then?)
        dbg('chan', "<- $sort $call $line\n") unless $sort eq 'D';
 
        # do the really sexy console interface bit! (Who is going to do the TK interface then?)
        dbg('chan', "<- $sort $call $line\n") unless $sort eq 'D';