X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=cmd%2Fget%2Fkeps.pl;h=36e075685af70dd06334317c18f324decd703a4d;hb=564b5b3a0c2fa40f00e015f8b05f3a87ea4e7e26;hp=54e386090534670d588fe06ea20e649525182706;hpb=b099b4a232e18d4204e10d0dbe0b63f741176baf;p=spider.git

diff --git a/cmd/get/keps.pl b/cmd/get/keps.pl
index 54e38609..36e07568 100644
--- a/cmd/get/keps.pl
+++ b/cmd/get/keps.pl
@@ -1,22 +1,134 @@
 #
-# Query the DB0SDX QSL server for a callsign
+# Obtain the latest keps from the Amsat site and
+# load them. 
 #
-# Copyright (c) 2003 Dirk Koopman G1TLH
-# Modified Dec 9, 2004 for new website and xml schema by David Spoelstra N9KT
-# and tidied up by me (Dirk)
+# This will clear out the old keps and rewrite the $root/local/Keps.pm 
+# file to retain the data.
 #
+# The main state machine code comes more or less straight out of convkeps.pl
+# This command is really to avoid the (even more) messy business of parsing emails
 #
+# Copyright (c) 2013 Dirk Koopman, G1TLH
 #
 
+# convert (+/-)00000-0 to (+/-).00000e-0
+sub genenum
+{
+	my ($sign, $frac, $esign, $exp) = unpack "aa5aa", shift;
+	$esign = '+' if $esign eq ' ';
+	my $n = $sign . "." . $frac . 'e' . $esign . $exp;
+	return $n - 0;
+}
+
 sub on_disc
 {
 	my $conn = shift;
 	my $dxchan = shift;
-	my @out;
 	
-	dbg("keps in: $conn->{kepsin}") if isdbg('keps');
+	if ($conn->{kepsin}) {
+		my $fn = "$main::root/local/Keps.pm";
+		my %keps;
+		
+		my @lines = split /[\r\n]+/, $conn->{kepsin};
+		my $state = 1;
+		my $line = 0;
+		my $ref;
+		my $count = 0;
+		my $name;
+		my %lookup = (
+					  'AO-5' => 'AO-05',
+					  'AO-6' => 'AO-06',
+					  'AO-7' => 'AO-07',
+					  'AO-8' => 'AO-08',
+					  'AO-9' => 'AO-09',
+					 );
+		for (@lines) {
+			
+			last if m{^-};
 
-	$dxchan->send("get/keps: new keps loaded");
+			s/^\s+//;
+			s/[\s\r]+$//;
+			next unless $_;
+			last if m{^/EX}i;
+			
+			dbg("keps: $state $_") if isdbg('keps');
+			
+			if ($state == 0 && /^Decode/i) {
+				$state = 1;
+			} elsif ($state == 1) {
+				last if m{^-};
+				next if m{^To\s+all}i;
+				
+				if (/^([- \w]+)(?:\s+\[[-+\w]\])?$/) {
+					my $n = uc $1;
+					dbg("keps: $state processing $n") if isdbg('keps');
+					$n =~ s/\s/-/g;
+					$name = $lookup{$n};
+					$name ||= $n;
+					$ref = $keps{$name} = {}; 
+					$state = 2;
+				}
+			} elsif ($state == 2) {
+				if (/^1 /) {
+					my ($id, $number, $epoch, $decay, $mm2, $bstar, $elset) = unpack "xxa5xxa5xxxa15xa10xa8xa8xxxa4x", $_;
+					dbg("keps: $state processing line 1 for $name") if isdbg('keps');
+					$ref->{id} = $id - 0;
+					$ref->{number} = $number - 0;
+					$ref->{epoch} = $epoch - 0;
+					$ref->{mm1} = $decay - 0;
+					$ref->{mm2} = genenum($mm2);
+					$ref->{bstar} = genenum($bstar);
+					$ref->{elset} = $elset - 0;
+					#print "$id $number $epoch $decay $mm2 $bstar $elset\n"; 
+					#print "mm2: $ref->{mm2} bstar: $ref->{bstar}\n";
+					
+					$state = 3;
+				} else {
+					#print "out of order on line $line\n";
+					dbg("keps: $state invalid or out of order line 1 for $name") if isdbg('keps');
+					undef $ref;
+					delete $keps{$name} if defined $name;
+					$state = 1;
+				}
+			} elsif ($state == 3) {
+				if (/^2 /) {
+					my ($id, $incl, $raan, $ecc, $peri, $man, $mmo, $orbit) = unpack "xxa5xa8xa8xa7xa8xa8xa11a5x", $_;
+					dbg("keps: $state processing line 2 for $name") if isdbg('keps');
+					$ref->{meananomaly} = $man - 0;
+					$ref->{meanmotion} = $mmo - 0;
+					$ref->{inclination} = $incl - 0;
+					$ref->{eccentricity} = ".$ecc" - 0;
+					$ref->{argperigee} = $peri - 0;
+					$ref->{raan} = $raan - 0;
+					$ref->{orbit} = $orbit - 0;
+					$count++;
+				} else {
+					#print "out of order on line $line\n";
+					dbg("keps: $state invalid or out of order line 2 for $name") if isdbg('keps');
+					delete $keps{$name};
+				}
+				undef $ref;
+				$state = 1;
+			}
+		}
+		if ($count) {
+			dbg("keps: $count recs, creating $fn") if isdbg('keps');
+			my $dd = new Data::Dumper([\%keps], [qw(*keps)]);
+			$dd->Indent(1);
+			$dd->Quotekeys(0);
+			open(OUT, ">$fn") or die "$fn $!";
+			print OUT "#\n# this file is automatically produced by the get/keps command\n#\n";
+			print OUT "# Last update: ", scalar gmtime, "\n#\n";
+			print OUT "\npackage Sun;\n\n";
+			print OUT $dd->Dumpxs;
+			print OUT "1;\n";
+			close(OUT);
+			dbg("keps: running load/keps") if isdbg('keps');
+			dbg("keps: clearing out old keps") if isdbg('keps');
+			%Sun::keps = ();
+			$dxchan->send($dxchan->run_cmd("load/keps"));
+		}
+	}
 }
 
 sub process
@@ -26,7 +138,7 @@ sub process
 
 	$conn->{kepsin} .= "$msg\n";
 	
-	dbg("keps in: $conn->{kepsin}") if isdbg('keps');
+#	dbg("keps in: $msg") if isdbg('keps');
 }
 
 sub handle
@@ -37,6 +149,7 @@ sub handle
 
 	$line = uc $line;
 	return (1, $self->msg('e24')) unless $Internet::allow;
+	return (1, $self->msg('e5')) if $self->priv < 8;
 	my $target = $Internet::keps_url || 'www.amsat.org';
 	my $path = $Internet::keps_path || '/amsat/ftp/keps/current/nasa.all';
 	my $port = 80;