cmd/get/keps.pl

   1 #
   2 # Obtain the latest keps from the Amsat site and
   3 # load them.
   4 #
   5 # This will clear out the old keps and rewrite the $root/local/Keps.pm
   6 # file to retain the data.
   7 #
   8 # The main state machine code comes more or less straight out of convkeps.pl
   9 # This command is really to avoid the (even more) messy business of parsing emails
  10 #
  11 # Copyright (c) 2013 Dirk Koopman, G1TLH
  12 #
  13
  14 # convert (+/-)00000-0 to (+/-).00000e-0
  15 sub genenum
  16 {
  17         my ($sign, $frac, $esign, $exp) = unpack "aa5aa", shift;
  18         $esign = '+' if $esign eq ' ';
  19         my $n = $sign . "." . $frac . 'e' . $esign . $exp;
  20         return $n - 0;
  21 }
  22
  23 sub on_disc
  24 {
  25         my $conn = shift;
  26         my $dxchan = shift;
  27
  28         if ($conn->{kepsin}) {
  29                 my $fn = "$main::root/local/Keps.pm";
  30                 my %keps;
  31
  32                 my @lines = split /[\r\n]+/, $conn->{kepsin};
  33                 my $state = 1;
  34                 my $line = 0;
  35                 my $ref;
  36                 my $count = 0;
  37                 my $name;
  38                 my %lookup = (
  39                                           'AO-5' => 'AO-05',
  40                                           'AO-6' => 'AO-06',
  41                                           'AO-7' => 'AO-07',
  42                                           'AO-8' => 'AO-08',
  43                                           'AO-9' => 'AO-09',
  44                                          );
  45                 for (@lines) {
  46
  47                         last if m{^-};
  48
  49                         s/^\s+//;
  50                         s/[\s\r]+$//;
  51                         next unless $_;
  52                         last if m{^/EX}i;
  53
  54                         dbg("keps: $state $_") if isdbg('keps');
  55
  56                         if ($state == 0 && /^Decode/i) {
  57                                 $state = 1;
  58                         } elsif ($state == 1) {
  59                                 last if m{^-};
  60                                 next if m{^To\s+all}i;
  61
  62                                 if (/^([- \w]+)(?:\s+\[[-+\w]\])?$/) {
  63                                         my $n = uc $1;
  64                                         dbg("keps: $state processing $n") if isdbg('keps');
  65                                         $n =~ s/\s/-/g;
  66                                         $name = $lookup{$n};
  67                                         $name ||= $n;
  68                                         $ref = $keps{$name} = {};
  69                                         $state = 2;
  70                                 }
  71                         } elsif ($state == 2) {
  72                                 if (/^1 /) {
  73                                         my ($id, $number, $epoch, $decay, $mm2, $bstar, $elset) = unpack "xxa5xxa5xxxa15xa10xa8xa8xxxa4x", $_;
  74                                         dbg("keps: $state processing line 1 for $name") if isdbg('keps');
  75                                         $ref->{id} = $id - 0;
  76                                         $ref->{number} = $number - 0;
  77                                         $ref->{epoch} = $epoch - 0;
  78                                         $ref->{mm1} = $decay - 0;
  79                                         $ref->{mm2} = genenum($mm2);
  80                                         $ref->{bstar} = genenum($bstar);
  81                                         $ref->{elset} = $elset - 0;
  82                                         #print "$id $number $epoch $decay $mm2 $bstar $elset\n";
  83                                         #print "mm2: $ref->{mm2} bstar: $ref->{bstar}\n";
  84
  85                                         $state = 3;
  86                                 } else {
  87                                         #print "out of order on line $line\n";
  88                                         dbg("keps: $state invalid or out of order line 1 for $name") if isdbg('keps');
  89                                         undef $ref;
  90                                         delete $keps{$name} if defined $name;
  91                                         $state = 1;
  92                                 }
  93                         } elsif ($state == 3) {
  94                                 if (/^2 /) {
  95                                         my ($id, $incl, $raan, $ecc, $peri, $man, $mmo, $orbit) = unpack "xxa5xa8xa8xa7xa8xa8xa11a5x", $_;
  96                                         dbg("keps: $state processing line 2 for $name") if isdbg('keps');
  97                                         $ref->{meananomaly} = $man - 0;
  98                                         $ref->{meanmotion} = $mmo - 0;
  99                                         $ref->{inclination} = $incl - 0;
 100                                         $ref->{eccentricity} = ".$ecc" - 0;
 101                                         $ref->{argperigee} = $peri - 0;
 102                                         $ref->{raan} = $raan - 0;
 103                                         $ref->{orbit} = $orbit - 0;
 104                                         $count++;
 105                                 } else {
 106                                         #print "out of order on line $line\n";
 107                                         dbg("keps: $state invalid or out of order line 2 for $name") if isdbg('keps');
 108                                         delete $keps{$name};
 109                                 }
 110                                 undef $ref;
 111                                 $state = 1;
 112                         }
 113                 }
 114                 if ($count) {
 115                         dbg("keps: $count recs, creating $fn") if isdbg('keps');
 116                         my $dd = new Data::Dumper([\%keps], [qw(*keps)]);
 117                         $dd->Indent(1);
 118                         $dd->Quotekeys(0);
 119                         open(OUT, ">$fn") or die "$fn $!";
 120                         print OUT "#\n# this file is automatically produced by the get/keps command\n#\n";
 121                         print OUT "# Last update: ", scalar gmtime, "\n#\n";
 122                         print OUT "\npackage Sun;\n\n";
 123                         print OUT $dd->Dumpxs;
 124                         print OUT "1;\n";
 125                         close(OUT);
 126                         dbg("keps: running load/keps") if isdbg('keps');
 127                         dbg("keps: clearing out old keps") if isdbg('keps');
 128                         %Sun::keps = ();
 129                         $dxchan->send($dxchan->run_cmd("load/keps"));
 130                 }
 131         }
 132 }
 133
 134 sub process
 135 {
 136         my $conn = shift;
 137         my $msg = shift;
 138
 139         $conn->{kepsin} .= "$msg\n";
 140
 141 #       dbg("keps in: $msg") if isdbg('keps');
 142 }
 143
 144 sub handle
 145 {
 146         my ($self, $line) = @_;
 147         my $call = $self->call;
 148         my @out;
 149
 150         $line = uc $line;
 151         return (1, $self->msg('e24')) unless $Internet::allow;
 152         return (1, $self->msg('e5')) if $self->priv < 8;
 153         my $target = $Internet::keps_url || 'www.amsat.org';
 154         my $path = $Internet::keps_path || '/amsat/ftp/keps/current/nasa.all';
 155         my $port = 80;
 156
 157         dbg("keps: contacting $target:$port") if isdbg('keps');
 158
 159         Log('call', "$call: show/keps $line");
 160         my $conn = AsyncMsg->post($self, $target, $port, $path,
 161                                                           filter => \&process,
 162                                                           on_disc => \&on_disc);
 163
 164         if ($conn) {
 165                 push @out, $self->msg('m21', "show/keps");
 166         } else {
 167                 push @out, $self->msg('e18', 'get/keps error');
 168         }
 169
 170         return (1, @out);
 171 }