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