perl/Geomag.pm

   1 #!/usr/bin/perl
   2 #
   3 # The geomagnetic information and calculation module
   4 # a chanfe
   5 #
   6 # Copyright (c) 1998 - Dirk Koopman G1TLH
   7 #
   8 # $Id$
   9 #
  10
  11 package Geomag;
  12
  13 use DXVars;
  14 use DXUtil;
  15 use DXLog;
  16 use Julian;
  17 use IO::File;
  18 use DXDebug;
  19 use DXDupe;
  20
  21 use strict;
  22 use vars qw($date $sfi $k $a $r $forecast @allowed @denied $fp $node $from
  23             $dirprefix $param
  24             $duplth $dupage $filterdef);
  25
  26 $fp = 0;                                                # the DXLog fcb
  27 $date = 0;                                              # the unix time of the WWV (notional)
  28 $sfi = 0;                                               # the current SFI value
  29 $k = 0;                                                 # the current K value
  30 $a = 0;                                                 # the current A value
  31 $r = 0;                                                 # the current R value
  32 $forecast = "";                                 # the current geomagnetic forecast
  33 $node = "";                                             # originating node
  34 $from = "";                                             # who this came from
  35 @allowed = ();                                  # if present only these callsigns are regarded as valid WWV updators
  36 @denied = ();                                   # if present ignore any wwv from these callsigns
  37 $duplth = 20;                                   # the length of text to use in the deduping
  38 $dupage = 12*3600;                              # the length of time to hold spot dups
  39
  40 $dirprefix = "$main::data/wwv";
  41 $param = "$dirprefix/param";
  42
  43 $filterdef = bless ([
  44                           # tag, sort, field, priv, special parser
  45                           ['by', 'c', 7],
  46                           ['origin', 'c', 8],
  47                           ['channel', 'n', 9],
  48                           ['by_dxcc', 'n', 10],
  49                           ['by_itu', 'n', 11],
  50                           ['by_zone', 'n', 12],
  51                           ['origin_dxcc', 'c', 13],
  52                           ['origin_itu', 'c', 14],
  53                           ['origin_itu', 'c', 15],
  54                          ], 'Filter::Cmd');
  55
  56 sub init
  57 {
  58         $fp = DXLog::new('wwv', 'dat', 'm');
  59         do "$param" if -e "$param";
  60         confess $@ if $@;
  61 }
  62
  63 # write the current data away
  64 sub store
  65 {
  66         my $fh = new IO::File;
  67         open $fh, "> $param" or confess "can't open $param $!";
  68         print $fh "# Geomagnetic data parameter file last mod:", scalar gmtime, "\n";
  69         print $fh "\$date = $date;\n";
  70         print $fh "\$sfi = $sfi;\n";
  71         print $fh "\$a = $a;\n";
  72         print $fh "\$k = $k;\n";
  73         print $fh "\$r = $r;\n";
  74         print $fh "\$from = '$from';\n";
  75         print $fh "\$node = '$node';\n";
  76         print $fh "\@denied = qw(", join(' ', @denied), ");\n" if @denied > 0;
  77         print $fh "\@allowed = qw(", join(' ', @allowed), ");\n" if @allowed > 0;
  78         close $fh;
  79
  80         # log it
  81         $fp->writeunix($date, "$from^$date^$sfi^$a^$k^$forecast^$node^$r");
  82 }
  83
  84 # update WWV info in one go (usually from a PC23)
  85 sub update
  86 {
  87         my ($mydate, $mytime, $mysfi, $mya, $myk, $myforecast, $myfrom, $mynode, $myr) = @_;
  88         if ((@allowed && grep {$_ eq $from} @allowed) ||
  89                 (@denied && !grep {$_ eq $from} @denied) ||
  90                 (@allowed == 0 && @denied == 0)) {
  91
  92                 #       my $trydate = cltounix($mydate, sprintf("%02d18Z", $mytime));
  93                 if ($mydate >= $date) {
  94                         if ($myr) {
  95                                 $r = 0 + $myr;
  96                         } else {
  97                                 $r = 0 unless abs ($mysfi - $sfi) > 3;
  98                         }
  99                         $sfi = 0 + $mysfi;
 100                         $k = 0 + $myk;
 101                         $a = 0 + $mya;
 102                         $forecast = $myforecast;
 103                         $date = $mydate;
 104                         $from = $myfrom;
 105                         $node = $mynode;
 106
 107                         store();
 108                 }
 109         }
 110 }
 111
 112 # add or substract an allowed callsign
 113 sub allowed
 114 {
 115         my $flag = shift;
 116         if ($flag eq '+') {
 117                 push @allowed, map {uc $_} @_;
 118         } else {
 119                 my $c;
 120                 foreach $c (@_) {
 121                         @allowed = map {$_ ne uc $c} @allowed;
 122                 }
 123         }
 124         store();
 125 }
 126
 127 # add or substract a denied callsign
 128 sub denied
 129 {
 130         my $flag = shift;
 131         if ($flag eq '+') {
 132                 push @denied, map {uc $_} @_;
 133         } else {
 134                 my $c;
 135                 foreach $c (@_) {
 136                         @denied = map {$_ ne uc $c} @denied;
 137                 }
 138         }
 139         store();
 140 }
 141
 142 # accessor routines (when I work how symbolic refs work I might use one of those!)
 143 sub sfi
 144 {
 145         @_ ? $sfi = shift : $sfi ;
 146 }
 147
 148 sub k
 149 {
 150         @_ ? $k = shift : $k ;
 151 }
 152
 153 sub r
 154 {
 155         @_ ? $r = shift : $r ;
 156 }
 157
 158 sub a
 159 {
 160         @_ ? $a = shift : $a ;
 161 }
 162
 163 sub forecast
 164 {
 165         @_ ? $forecast = shift : $forecast ;
 166 }
 167
 168
 169 #
 170 # print some items from the log backwards in time
 171 #
 172 # This command outputs a list of n lines starting from line $from to $to
 173 #
 174 sub search
 175 {
 176         my $from = shift;
 177         my $to = shift;
 178         my @date = $fp->unixtoj(shift);
 179         my $pattern = shift;
 180         my $search;
 181         my @out;
 182         my $eval;
 183         my $count;
 184
 185         $search = 1;
 186         $eval = qq(
 187                            my \$c;
 188                            my \$ref;
 189                            for (\$c = \$#in; \$c >= 0; \$c--) {
 190                                         \$ref = \$in[\$c];
 191                                         if ($search) {
 192                                                 \$count++;
 193                                                 next if \$count < \$from;
 194                                                 push \@out, \$ref;
 195                                                 last if \$count >= \$to; # stop after n
 196                                         }
 197                                 }
 198                           );
 199
 200         $fp->close;                                     # close any open files
 201
 202         my $fh = $fp->open(@date);
 203         for ($count = 0; $count < $to; ) {
 204                 my @in = ();
 205                 if ($fh) {
 206                         while (<$fh>) {
 207                                 chomp;
 208                                 push @in, [ split '\^' ] if length > 2;
 209                         }
 210                         eval $eval;                     # do the search on this file
 211                         return ("Geomag search error", $@) if $@;
 212                         last if $count >= $to; # stop after n
 213                 }
 214                 $fh = $fp->openprev();  # get the next file
 215                 last if !$fh;
 216         }
 217
 218         return @out;
 219 }
 220
 221 #
 222 # the standard log printing interpreting routine.
 223 #
 224 # every line that is printed should call this routine to be actually visualised
 225 #
 226 # Don't really know whether this is the correct place to put this stuff, but where
 227 # else is correct?
 228 #
 229 # I get a reference to an array of items
 230 #
 231 sub print_item
 232 {
 233         my $r = shift;
 234         my @ref = @$r;
 235         my $d = cldate($ref[1]);
 236         my ($t) = (gmtime($ref[1]))[2];
 237
 238         return sprintf("$d   %02d %5d %3d %3d %-37s <%s>", $t, $ref[2], $ref[3], $ref[4], $ref[5], $ref[0]);
 239 }
 240
 241 #
 242 # read in this month's data
 243 #
 244 sub readfile
 245 {
 246         my @date = $fp->unixtoj(shift);
 247         my $fh = $fp->open(@date);
 248         my @spots = ();
 249         my @in;
 250
 251         if ($fh) {
 252                 while (<$fh>) {
 253                         chomp;
 254                         push @in, [ split '\^' ] if length > 2;
 255                 }
 256         }
 257         return @in;
 258 }
 259
 260 # enter the spot for dup checking and return true if it is already a dup
 261 sub dup
 262 {
 263         my ($d, $sfi, $k, $a, $text) = @_;
 264
 265         # dump if too old
 266         return 2 if $d < $main::systime - $dupage;
 267
 268         my $dupkey = "W$d|$sfi|$k|$a";
 269         return DXDupe::check($dupkey, $main::systime+$dupage);
 270 }
 271
 272 sub listdups
 273 {
 274         return DXDupe::listdups('W', $dupage, @_);
 275 }
 276 1;
 277 __END__;
 278