X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXProt.pm;h=6e5efeafbe3246ab9c106479287316d3e3d014be;hb=970d8ae5f1c263bc78390ca35ee876aa41382f21;hp=88aef0db00395a2be049f12f8590be58d66c529d;hpb=f155969d600561b9ef151a7ce2494a0c89aed033;p=spider.git

diff --git a/perl/DXProt.pm b/perl/DXProt.pm
index 88aef0db..6e5efeaf 100644
--- a/perl/DXProt.pm
+++ b/perl/DXProt.pm
@@ -34,10 +34,9 @@ use strict;
 use vars qw($me $pc11_max_age $pc23_max_age
 			$last_hour %pings %rcmds
 			%nodehops @baddx $baddxfn 
-			$allowzero $decode_dk0wcy);
+			$allowzero $decode_dk0wcy $send_opernam @checklist);
 
 $me = undef;					# the channel id for this cluster
-$decode_dk0wcy = undef;			# if set use this callsign to decode announces from the EU WWV data beacon
 $pc11_max_age = 1*3600;			# the maximum age for an incoming 'real-time' pc11
 $pc23_max_age = 1*3600;			# the maximum age for an incoming 'real-time' pc23
 
@@ -50,6 +49,123 @@ $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 m d t m c c h) ],		# pc11
+ [ qw(c bc m bp bm 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(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 n n n n m c c h) ],		# pc23
+ [ qw(c p h) ],					# pc24
+ [ qw(c c n n) ],				# pc25
+ [ qw(f m d t m c c bc) ],		# pc26
+ [ qw(d n n n n m c c bc) ],	# pc27
+ [ qw(c c c c d t p m bp n p bp bc) ], # 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
+ undef,							# pc38 not interested
+ [ 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 n n n n n n m m m c c h) ],	# 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 < 0 || $n > @checklist; 
+	my $ref = $checklist[$n];
+	return 0 unless ref $ref;
+	
+	my $i;
+	shift;    # not interested in the first field
+	for ($i = 0; $i < @$ref; $i++) {
+		my ($blank, $act) = $$ref[$i] =~ /^(b?)(\w)$/;
+		return 0 unless $act;
+		next if $blank && $_[$i] =~ /^[ \*]$/;
+		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 unless $_[$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);
@@ -59,16 +175,16 @@ sub init
 	$me->{state} = "indifferent";
 	do "$main::data/hop_table.pl" if -e "$main::data/hop_table.pl";
 	confess $@ if $@;
-	#  $me->{sort} = 'M';    # M for me
+	$me->{sort} = 'S';    # S for spider
 
 	# now prime the spot and wwv  duplicates file with data
-    my @today = Julian::unixtoj(time);
-	for (Spot::readfile(@today), Spot::readfile(Julian::sub(@today, 1))) {
-		Spot::dup(@{$_}[0..3]);
-	}
-	for (Geomag::readfile(time)) {
-		Geomag::dup(@{$_}[1..5]);
-	}
+#    my @today = Julian::unixtoj(time);
+#	for (Spot::readfile(@today), Spot::readfile(Julian::sub(@today, 1))) {
+#		Spot::dup(@{$_}[0..3]);
+#	}
+#	for (Geomag::readfile(time)) {
+#		Geomag::dup(@{$_}[1..5]);
+#	}
 
 	# load the baddx file
 	do "$baddxfn" if -e "$baddxfn";
@@ -97,8 +213,8 @@ sub start
 	# remember type of connection
 	$self->{consort} = $line;
 	$self->{outbound} = $sort eq 'O';
-	$self->{priv} = $user->priv;
-	$self->{lang} = $user->lang;
+	$self->{priv} = $user->priv || 1;     # other clusters can always be 'normal' users
+	$self->{lang} = $user->lang || 'en';
 	$self->{isolate} = $user->{isolate};
 	$self->{consort} = $line;	# save the connection type
 	$self->{here} = 1;
@@ -106,6 +222,7 @@ sub start
 	# get the INPUT filters (these only pertain to Clusters)
 	$self->{inspotfilter} = Filter::read_in('spots', $call, 1);
 	$self->{inwwvfilter} = Filter::read_in('wwv', $call, 1);
+	$self->{inwcyfilter} = Filter::read_in('wcy', $call, 1);
 	$self->{inannfilter} = Filter::read_in('ann', $call, 1);
 	
 	# set unbuffered and no echo
@@ -158,9 +275,10 @@ sub normal
 	return unless $pcno;
 	return if $pcno < 10 || $pcno > 99;
 
-	# dump bad protocol messages unless it is a PC29
-	if ($line =~ /\%[0-9A-F][0-9A-F]/o && $pcno != 29) {
-		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;
 	}
 
@@ -176,15 +294,19 @@ sub normal
 		if ($pcno == 10) {		# incoming talk
 			
 			# is it for me or one of mine?
-			my $call = ($field[5] gt ' ') ? $field[5] : $field[2];
-			if ($call eq $main::mycall || grep $_ eq $call, DXChannel::get_all_user_calls()) {
-				
-				# yes, it is
-				my $text = unpad($field[3]);
-				Log('talk', $call, $field[1], $field[6], $text);
-				$call = $main::myalias if $call eq $main::mycall;
-				my $ref = DXChannel->get($call);
-				$ref->send("$call de $field[1]: $text") if $ref && $ref->{talk};
+			my ($to, $via, $call, $dxchan);
+			if ($field[5] gt ' ') {
+				$call = $via = $field[2];
+				$to = $field[5];
+				unless (is_callsign($to)) {
+					dbg('chan', "Corrupt talk, rejected");
+					return;
+				}
+			} else {
+				$call = $to = $field[2];
+			}
+			if ($dxchan = DXChannel->get($call)) {
+				$dxchan->talk($field[1], $to, $via, $field[3]);
 			} else {
 				$self->route($field[2], $line); # relay it on its way
 			}
@@ -220,14 +342,9 @@ sub normal
 				dbg('chan', "Bad DX spot, ignored");
 				return;
 			}
-
-			# are any of the crucial fields invalid?
-            if ($field[2] =~ /[a-z]/ || $field[6] =~ /[a-z]/ || $field[7] =~ /[a-z]/) {
-				dbg('chan', "Spot contains lower case callsigns, rejected");
-				return;
-			}
 			
 			# do some de-duping
+			$field[5] =~ s/^\s+//;      # take any leading blanks off
 			if (Spot::dup($field[1], $field[2], $d, $field[5])) {
 				dbg('chan', "Duplicate Spot ignored\n");
 				return;
@@ -242,6 +359,49 @@ sub normal
 			# you should be able to route on any of these
             #
 			
+			# fix up qra locators of known users 
+			my $user = DXUser->get_current($spot[4]);
+			if ($user) {
+				my $qra = $user->qra;
+				unless ($qra && DXBearing::is_qra($qra)) {
+					my $lat = $user->lat;
+					my $long = $user->long;
+					if (defined $lat && defined $long) {
+						$user->qra(DXBearing::lltoqra($lat, $long)); 
+						$user->put;
+					}
+				}
+
+				# send a remote command to a distant cluster if it is visible and there is no
+				# qra locator and we havn't done it for a month.
+
+				unless ($user->qra) {
+					my $node;
+					my $to = $user->homenode;
+					my $last = $user->lastoper || 0;
+					if ($send_opernam && $main::systime > $last + $DXUser::lastoperinterval && $to && ($node = DXCluster->get_exact($to)) ) {
+						my $cmd = "forward/opernam $spot[4]";
+						# send the rcmd but we aren't interested in the replies...
+						if ($node && $node->dxchan && $node->dxchan->is_clx) {
+							route(undef, $to, pc84($main::mycall, $to, $main::mycall, $cmd));
+						} else {
+							route(undef, $to, pc34($main::mycall, $to, $cmd));
+						}
+						if ($to ne $field[7]) {
+							$to = $field[7];
+							$node = DXCluster->get_exact($to);
+							if ($node && $node->dxchan && $node->dxchan->is_clx) {
+								route(undef, $to, pc84($main::mycall, $to, $main::mycall, $cmd));
+							} else {
+								route(undef, $to, pc34($main::mycall, $to, $cmd));
+							}
+						}
+						$user->lastoper($main::systime);
+						$user->put;
+					}
+				}
+			}
+				
 			# local processing 
 			my $r;
 			eval {
@@ -260,6 +420,7 @@ sub normal
 		
 		if ($pcno == 12) {		# announces
 			# announce duplicate checking
+			$field[3] =~ s/^\s+//;  # remove leading blanks
 			if (AnnTalk::dup($field[1], $field[2], $field[3])) {
 				dbg('chan', "Duplicate Announce ignored\n");
 				return;
@@ -278,13 +439,6 @@ sub normal
 
 				# send it
 				$self->send_announce($line, @field[1..6]);
-				
-				if ($decode_dk0wcy && $field[1] eq $decode_dk0wcy) {
-					my ($hour, $k, $next, $a, $r, $sfi, $alarm) = $field[3] =~ /^Aurora Beacon\s+(\d+)UTC,\s+Kiel\s+K=(\d+),.*ed\s+K=(\d+),\s+A=(\d+),\s+R=(\d+),\s+SFI=(\d+),.*larm:\s+(\w+)/;
-					$alarm = ($alarm =~ /^Y/i) ? ', Aurora in DE' : ''; 
-					my $wwv = Geomag::update($main::systime, $hour, $sfi, $a, $k, "R=$r, Next K=$next$alarm", $decode_dk0wcy, $field[5], $r) if $sfi && $r;
-				}
-				
 			} else {
 				$self->route($field[2], $line);
 			}
@@ -581,7 +735,7 @@ sub normal
 				my $ref = DXUser->get_current($field[2]);
 				my $cref = DXCluster->get($field[2]);
 				Log('rcmd', 'in', $ref->{priv}, $field[2], $field[3]);
-				unless ($field[3] =~ /rcmd/i || !$cref || !$ref || $cref->mynode->call ne $ref->homenode) {    # not allowed to relay RCMDS!
+				unless (!$cref || !$ref || $cref->mynode->call ne $ref->homenode) {    # not allowed to relay RCMDS!
 					if ($ref->{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
 						my $oldpriv = $self->{priv};
@@ -618,6 +772,10 @@ sub normal
 					my $dxchan = DXChannel->get($s->{call});
 					$dxchan->send($field[3]) if $dxchan;
 					delete $rcmds{$field[2]} if !$dxchan;
+				} else {
+					# send unsolicited ones to the sysop
+					my $dxchan = DXChannel->get($main::myalias);
+					$dxchan->send($field[3]) if $dxchan;
 				}
 			} else {
 				my $ref = DXUser->get_current($field[1]);
@@ -659,9 +817,11 @@ sub normal
 				my ($lat, $long) = DXBearing::stoll($field[3]);
 				$user->lat($lat);
 				$user->long($long);
+				$user->qra(DXBearing::lltoqra($lat, $long)) unless $user->qra && DXBearing::is_qra($user->qra);
 			} elsif ($field[2] == 4) {
 				$user->homenode($field[3]);
 			}
+			$user->lastoper($main::systime);   # to cut down on excessive for/opers being generated
 			$user->put;
 			last SWITCH;
 		}
@@ -759,7 +919,7 @@ sub normal
 				my $ref = DXUser->get_current($field[2]);
 				my $cref = DXCluster->get($field[2]);
 				Log('rcmd', 'in', $ref->{priv}, $field[2], $field[4]);
-				unless ($field[3] =~ /rcmd/i || !$cref || !$ref || $cref->mynode->call ne $ref->homenode) {    # not allowed to relay RCMDS!
+				unless ($field[4] =~ /rcmd/i || !$cref || !$ref || $cref->mynode->call ne $ref->homenode) {    # not allowed to relay RCMDS!
 					if ($ref->{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
 						my $oldpriv = $self->{priv};
@@ -783,7 +943,7 @@ sub normal
 				if ($ref && $ref->is_clx) {
 					$self->route($field[1], $line);
 				} else {
-					route($field[1], pc34($field[2], $field[1], $field[3]));
+					route($field[1], pc34($field[2], $field[1], $field[4]));
 				}
 			}
 			return;
@@ -800,6 +960,10 @@ sub normal
 						$dxchan = DXChannel->get($s->{call});
 						$dxchan->send($field[4]) if $dxchan;
 						delete $rcmds{$field[2]} if !$dxchan;
+					} else {
+						# send unsolicited ones to the sysop
+						my $dxchan = DXChannel->get($main::myalias);
+						$dxchan->send($field[4]) if $dxchan;
 					}
 				}
 			} else {
@@ -807,7 +971,7 @@ sub normal
 				if ($ref && $ref->is_clx) {
 					$self->route($field[1], $line);
 				} else {
-					route($field[1], pc35($field[2], $field[1], $field[3]));
+					route($field[1], pc35($field[2], $field[1], $field[4]));
 				}
 			}
 			return;
@@ -863,9 +1027,9 @@ sub process
 	my $val;
 	my $cutoff;
 	if ($main::systime - 3600 > $last_hour) {
-		Spot::process;
-		Geomag::process;
-		AnnTalk::process;
+#		Spot::process;
+#		Geomag::process;
+#		AnnTalk::process;
 		$last_hour = $main::systime;
 	}
 }
@@ -877,11 +1041,9 @@ sub finish
 {
 	my $self = shift;
 	my $call = $self->call;
-	my $nopc39 = shift;
+	my $conn = shift;
 	my $ref = DXCluster->get_exact($call);
 	
-	$self->send_now("D", DXProt::pc39($main::mycall, $self->msg('disc1', "System Op"))) unless $nopc39;
-	
 	# unbusy and stop and outgoing mail
 	my $mref = DXMsg::get_busy($call);
 	$mref->stop_msg($call) if $mref;
@@ -948,9 +1110,9 @@ sub send_dx_spot
 				$dxchan->send($routeit) unless $dxchan->{isolate} || $self->{isolate};
 			}
 		} elsif ($dxchan->is_user && $dxchan->{dx}) {
-			my $buf = Spot::formatb($_[0], $_[1], $_[2], $_[3], $_[4]);
+			my $buf = Spot::formatb($dxchan->{user}->wantgrid, $_[0], $_[1], $_[2], $_[3], $_[4]);
 			$buf .= "\a\a" if $dxchan->{beep};
-			if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') {
+			if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') {
 				$dxchan->send($buf);
 			} else {
 				$dxchan->delay($buf);
@@ -994,7 +1156,7 @@ sub send_wwv_spot
 		} elsif ($dxchan->is_user && $dxchan->{wwv}) {
 			my $buf = "WWV de $_[6] <$_[1]>:   SFI=$_[2], A=$_[3], K=$_[4], $_[5]";
 			$buf .= "\a\a" if $dxchan->{beep};
-			if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') {
+			if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') {
 				$dxchan->send($buf);
 			} else {
 				$dxchan->delay($buf);
@@ -1037,7 +1199,7 @@ sub send_wcy_spot
 		} elsif ($dxchan->is_user && $dxchan->{wcy}) {
 			my $buf = "WCY de $_[10] <$_[1]> : K=$_[4] expK=$_[5] A=$_[3] R=$_[6] SFI=$_[2] SA=$_[7] GMF=$_[8] Au=$_[9]";
 			$buf .= "\a\a" if $dxchan->{beep};
-			if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') {
+			if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') {
 				$dxchan->send($buf);
 			} else {
 				$dxchan->delay($buf);
@@ -1101,7 +1263,7 @@ sub send_announce
 			next if $target eq 'SYSOP' && $dxchan->{priv} < 5;
 			my $buf = "$to$target de $_[0]: $text";
 			$buf .= "\a\a" if $dxchan->{beep};
-			if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') {
+			if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') {
 				$dxchan->send($buf);
 			} else {
 				$dxchan->delay($buf);
@@ -1252,7 +1414,7 @@ sub broadcast_list
 
 		$s =~ s/\a//og unless $dxchan->{beep};
 
-		if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') {
+		if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') {
 			$dxchan->send($s);	
 		} else {
 			$dxchan->delay($s);
@@ -1350,5 +1512,30 @@ sub addrcmd
 		route(undef, $to, pc34($main::mycall, $to, $cmd));
 	}
 }
+
+sub disconnect
+{
+	my $self = shift;
+	my $nopc39 = shift;
+
+	if ($self->{conn} && !$nopc39) {
+		$self->send_now("D", DXProt::pc39($main::mycall, $self->msg('disc1', "System Op")));
+	}
+
+	$self->SUPER::disconnect;
+}
+
+
+# 
+# send a talk message to this thingy
+#
+sub talk
+{
+	my ($self, $from, $to, $via, $line) = @_;
+	
+	$line =~ s/\^/\\5E/g;			# remove any ^ characters
+	$self->send(DXProt::pc10($from, $to, $via, $line));
+	Log('talk', $self->call, $from, $via?$via:$main::mycall, $line);
+}
 1;
 __END__