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