2. Add full individual checking for all PC protocol fields in all messages

and removed any language dependant stuff (hopefully).

diff --git a/Changes b/Changes
index 25a1007d8dffa775ef724ea1e9cf6bd5036531bc..10f58fb7f78fb65e9b69807783a8a0aa6ab69682 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 20Aug00=======================================================================
 1. Added system Alias for set/nodxgrid => unset/dxgrid
+2. Add full individual checking for all PC protocol fields in all messages
+and removed any language dependant stuff (hopefully).
 19Aug00=======================================================================
 1. Added an efficiency thing for AUTOLOADed accessors from OO Perl by Conway.
 2. Fiddled with the rtty and digital bandplan frequencies.

diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm
index a1c63407f71f1b2aba38c58782dbe77f0a73e63b..ac452413555d4975dc3750bcaad5d120234fefaa 100644 (file)
--- a/perl/DXDebug.pm
+++ b/perl/DXDebug.pm
@@ -56,6 +56,8 @@ sub _store
                chomp;
                my @l = split /\n/;
                for (@l) {
+                       my $l = $_;
+                       $l =~ s/([\x00\x08\x0B-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;                 
                        print "$_\n" if defined \*STDOUT;
                        $fp->writeunix($t, "$t^$_"); 
                }

diff --git a/perl/DXProt.pm b/perl/DXProt.pm
index 5ba3b2bd97b0feb7192a2a3847b3e2bf89a693d4..4f9e22202f88b044668590f58b06c0fd4339ac12 100644 (file)
--- a/perl/DXProt.pm
+++ b/perl/DXProt.pm
@@ -34,7 +34,7 @@ use strict;
 use vars qw($me $pc11_max_age $pc23_max_age
                        $last_hour %pings %rcmds
                        %nodehops @baddx $baddxfn 
-                       $allowzero $decode_dk0wcy $send_opernam);
+                       $allowzero $decode_dk0wcy $send_opernam @checklist);
 
 $me = undef;                                   # the channel id for this cluster
 $pc11_max_age = 1*3600;                        # the maximum age for an incoming 'real-time' pc11
@@ -49,6 +49,121 @@ $last_hour = time;                          # last time I did an hourly periodic update
 
 $baddxfn = "$main::data/baddx.pl";
 
+@checklist = 
+(
+ qw(c c m p bc c),                             # pc10
+ qw(f c m d t c c h),                  # pc11
+ qw(c bc m p c p h),                   # pc12
+ qw(c h),
+ qw(c h),
+ qw(c m h),
+ undef,                                                        # pc16 has to be validated manually
+ qw(c c h),                                            # pc17
+ qw(c m n),                                            # pc18
+ undef,                                                        # pc19 has to be validated manually
+ undef,                                                        # pc20 no validation
+ qw(c m h),                                            # pc21
+ undef,                                                        # pc22 no validation
+ qw(d t n n n m c c h),                        # pc23
+ qw(c p h),                                            # pc24
+ qw(c c n n),                                  # pc25
+ qw(f c m d t c c),                            # pc26
+ qw(d t n n n m c c),                  # pc27
+ qw(c c c c d t p m bp n p bp c), # pc28
+ qw(c c n m),                                  # pc29
+ qw(c c n),                                            # pc30
+ qw(c c n),                                            # pc31
+ qw(c c n),                                            # pc32
+ qw(c c n),                                            # pc33
+ qw(c c m),                                            # pc34
+ qw(c c m),                                            # pc35
+ qw(c c m),                                            # pc36
+ qw(c c n m),                                  # pc37
+ qw(c m),                                              # pc39
+ qw(c c m p n),                                        # pc40
+ qw(c n m h),                                  # pc41
+ qw(c c n),                                            # pc42
+ undef,                                                        # pc43 don't handle it
+ qw(c c n m m c),                              # pc44
+ qw(c c n m),                                  # pc45
+ qw(c c n),                                            # pc46
+ undef,                                                        # pc47
+ undef,                                                        # pc48
+ qw(c m h),                                            # pc49
+ qw(c n h),                                            # pc50
+ qw(c c n),                                            # pc51
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,                                                        # pc60
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,                                                        # pc70
+ undef,
+ undef,
+ qw(d t n n n n n n m m m c c),        # pc73
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,
+ undef,                                                        # pc80
+ undef,
+ undef,
+ undef,
+ qw(c c c m),                                  # pc84
+ qw(c c c m),                                  # pc85
+);
+
+# use the entry in the check list to check the field list presented
+# return OK if line NOT in check list (for now)
+sub check
+{
+       my $n = shift;
+       $n -= 10;
+       return 0 if $n < 10 || $n > @checklist; 
+       my $ref = $checklist[$n];
+       return 0 unless ref $ref;
+       
+       my $i;
+       shift;    # not interested in the first field
+       for ($i = 0; $i < @_; $i++) {
+               my ($blank, $act) = $$ref[$i] =~ /^(b?)(\w)$/;
+               next if $blank && $_[$i] eq ' ';
+               if ($act eq 'c') {
+                       return $i+1 unless is_callsign($_[$i]);
+               } elsif ($act eq 'm') {
+                       return $i+1 unless is_pctext($_[$i]);
+               } elsif ($act eq 'p') {
+                       return $i+1 unless is_pcflag($_[$i]);
+               } elsif ($act eq 'f') {
+                       return $i+1 unless is_freq($_[$i]);
+               } elsif ($act eq 'n') {
+                       return $i+1 if $_[$i] !~ /^[^\d ]$/;
+               } elsif ($act eq 'h') {
+                       return $i+1 unless $_[$i] =~ /^H\d\d?$/;
+               } elsif ($act eq 'd') {
+                       return $i+1 unless $_[$i] =~ /^\s*\d+-\w\w\w-[12][90]\d\d$/;
+               } elsif ($act eq 't') {
+                       return $i+1 unless $_[$i] =~ /^[012]\d[012345]\dZ$/;
+               }
+       }
+       return 0;
+}
+
 sub init
 {
        my $user = DXUser->get($main::mycall);
@@ -158,9 +273,10 @@ sub normal
        return unless $pcno;
        return if $pcno < 10 || $pcno > 99;
 
-       # dump bad protocol messages
-       if ($pcno != 29 && $line =~ /\%[01][0-9A-F]/) {
-               dbg('chan', "CORRUPT protocol message - dumped");
+       # check for and dump bad protocol messages
+       my $n = check($pcno, @field);
+       if ($n) {
+               dbg('chan', "bad field $n, dumped (" . parray($checklist[$pcno-10]) . ")");
                return;
        }
 
@@ -175,10 +291,6 @@ sub normal
  SWITCH: {
                if ($pcno == 10) {              # incoming talk
                        
-                       unless (is_callsign($field[1]) && is_callsign($field[2]) && is_callsign($field[6])) {
-                               dbg('chan', "Corrupt talk, rejected");
-                               return;
-                       }
                        # is it for me or one of mine?
                        my ($to, $via, $call, $dxchan);
                        if ($field[5] gt ' ') {
@@ -201,16 +313,6 @@ sub normal
                
                if ($pcno == 11 || $pcno == 26) { # dx spot
 
-                       # are any of the callsign fields invalid?
-            unless ($field[2] !~ m/[^A-Z0-9\-\/]/ && is_callsign($field[6]) && is_callsign($field[7])) {
-                               dbg('chan', "Spot contains lower case callsigns or blanks, rejected");
-                               return;
-                       }
-            if ($field[1] =~ m/[^0-9\.]/) {
-                               dbg('chan', "Spot frequency not numeric, rejected");
-                               return;
-                       }
-
                        # route 'foreign' pc26s 
                        if ($pcno == 26) {
                                if ($field[7] ne $main::mycall) {
@@ -315,11 +417,6 @@ sub normal
                }
                
                if ($pcno == 12) {              # announces
-                       unless (is_callsign($field[1]) && is_callsign($field[5])) {
-                               dbg('chan', "Corrupt announce, rejected");
-                               return;
-                       }
-
                        # announce duplicate checking
                        $field[3] =~ s/^\s+//;  # remove leading blanks
                        if (AnnTalk::dup($field[1], $field[2], $field[3])) {

diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm
index d1079035b1ada28fa5b1133ef3c8bd06a3d3ea5c..0fb6b8dbb848cc3c9aaf669fb1987e780f726fac 100644 (file)
--- a/perl/DXUtil.pm
+++ b/perl/DXUtil.pm
@@ -17,6 +17,7 @@ require Exporter;
 @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf 
                         parray parraypairs shellregex readfilestr writefilestr
              print_all_fields cltounix iscallsign unpad is_callsign
+                        is_freq is_digits
             );
 
 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@@ -301,8 +302,20 @@ sub is_pctext
        return $_[0] !~ /[^\x20-\xA8\xE0-\xEF]/;
 }
 
-# check that a PC prot flag is set correctly
+# check that a PC prot flag is fairly valid (doesn't check the difference between 1/0 and */-)
 sub is_pcflag
 {
-       return $_[0] !~ /^[^01\*]$/;
+       return $_[0] !~ /^[^01\*\-]$/;
+}
+
+# check that a thing is a frequency
+sub is_freq
+{
+       return $_[0] !~ /[^\d\.]/;
+}
+
+# check that a thing is just digits
+sub is_digits
+{
+       return $_[0] !~ /[^\d]/;
 }

diff --git a/perl/Prot.pm b/perl/Prot.pm
index 4576196a28533f81a44897c55f2a207bbd0ee6f1..67741752c0b495f094bc7a5dbf898857cb0136f4 100644 (file)
--- a/perl/Prot.pm
+++ b/perl/Prot.pm
@@ -6,13 +6,56 @@ package Prot;
 
 use strict;
 
+use DXUtil;
+use DXDebug;
+use vars qw(%valid);
+
+%valid = (
+                 fromnode => '0,From Node',
+                 tonode => '0,To Node',
+                 vianode => '0,Via Node',
+                 origin => '0,Original Node',
+                 tocall => '0,To Callsign',
+                 fromcall => '0,From Callsign',
+                 hops => '0,No. of hops',
+                 text => '0,Text',
+                 datetime => '0,Date/Time,atime',
+                 freq => '0,Frequency',
+                 dxcall => '0,DX Callsign',
+                 sort => '0,Sort',
+                 hereflag => '0,Here?,yesno',
+                 talkflag => '0,Talk mode',
+                 bellflag => '0,Bell?',
+                 privflag => '0,Private?,yesno',
+                 rrflag => '0,RR Req.?,yesno',
+                 sysopflag => '0,Sysop flag',
+                 dxcount => '0,DX Count',
+                 wwvcount => '0,WWV Count',
+                 version => '0,Node Version',
+                 nodelist => '0,Node List,parray',
+                );
+
+
 sub new
 {
        my $pkg = shift;
-       my $self = bless {}, $pkg;
+       my $sort = shift;
+       my $self = bless { sort => $sort }, $pkg;
        return $self;
 }
 
+sub AUTOLOAD
+{
+       no strict "refs";
+       my $self = shift;
+       my $name = $AUTOLOAD;
+       return if $name =~ /::DESTROY$/;
+       $name =~ s/.*:://o;
+  
+       confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
+       *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
+    @_ ? $self->{$name} = shift : $self->{$name} ;
+}
 
 1;
 __END__

diff --git a/perl/cluster.pl b/perl/cluster.pl
index 1ecbc094a704487fd96c3998a560eb493d02f976..ec1030e88096a659e1b4480c7bf78572a2ac874a 100755 (executable)
--- a/perl/cluster.pl
+++ b/perl/cluster.pl
@@ -253,11 +253,6 @@ sub process_inqueue
        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;
-       }
-
        # 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';