perl/Geomag.pm

   1 #!/usr/bin/perl
   2 #
   3 # The geomagnetic information and calculation module
   4 #
   5 # Copyright (c) 1998 - Dirk Koopman G1TLH
   6 #
   7 # $Id$
   8 #
   9
  10 package Geomag;
  11
  12 use DXVars;
  13 use DXUtil;
  14 use FileHandle;
  15 use Carp;
  16
  17 use strict;
  18 use vars qw($date $sfi $k $a $forecast @allowed @denied);
  19
  20 $date = 0;          # the unix time of the WWV (notional)
  21 $sfi = 0;           # the current SFI value
  22 $k = 0;             # the current K value
  23 $a = 0;             # the current A value
  24 $forecast = "";     # the current geomagnetic forecast
  25 @allowed = ();      # if present only these callsigns are regarded as valid WWV updators
  26 @denied = ();       # if present ignore any wwv from these callsigns
  27 my $dirprefix = "$main::data/wwv";
  28 my $param = "$dirprefix/param";
  29
  30 sub init
  31 {
  32   mkdir $dirprefix, 0777 if !-e $dirprefix;
  33   do "$param" if -e "$param";
  34   confess $@ if $@;
  35 }
  36
  37 # write the current data away
  38 sub store
  39 {
  40   my $fh = new FileHandle;
  41   open $fh, "> $param" or confess "can't open $param $!";
  42   print $fh "# Geomagnetic data parameter file last mod:", scalar gmtime, "\n";
  43   print $fh "\$date = $date;\n";
  44   print $fh "\$sfi = $sfi;\n";
  45   print $fh "\$a = $a;\n";
  46   print $fh "\$k = $k;\n";
  47   print $fh "\$forecast = '$forecast';\n";
  48   print $fh "\@denied = qw(", join(' ', @denied), ");\n" if @denied > 0;
  49   print $fh "\@allowed = qw(", join(' ', @allowed), ");\n" if @allowed > 0;
  50   close $fh;
  51 }
  52
  53 # update WWV info in one go (usually from a PC23)
  54 sub update
  55 {
  56   my ($mydate, $mytime, $mysfi, $mya, $myk, $myforecast, $from, $node) = @_;
  57   if ((@allowed && grep {$_ eq $from} @allowed) ||
  58       (@denied && !grep {$_ eq $from} @denied) ||
  59           (@allowed == 0 && @denied == 0)) {
  60
  61         my $trydate = cltounix($mydate, sprintf("%02d18Z", $mytime));
  62         if ($trydate >= $date) {
  63       $sfi = 0 + $mysfi;
  64       $k = 0 + $myk;
  65       $a = 0 + $mya;
  66       $forecast = $myforecast;
  67           store();
  68         }
  69   }
  70 }
  71
  72 # add or substract an allowed callsign
  73 sub allowed
  74 {
  75   my $flag = shift;
  76   if ($flag eq '+') {
  77     push @allowed, map {uc $_} @_;
  78   } else {
  79     my $c;
  80     foreach $c (@_) {
  81           @allowed = map {$_ ne uc $c} @allowed;
  82         }
  83   }
  84   store();
  85 }
  86
  87 # add or substract a denied callsign
  88 sub denied
  89 {
  90   my $flag = shift;
  91   if ($flag eq '+') {
  92     push @denied, map {uc $_} @_;
  93   } else {
  94     my $c;
  95     foreach $c (@_) {
  96           @denied = map {$_ ne uc $c} @denied;
  97         }
  98   }
  99   store();
 100 }
 101
 102 # accessor routines (when I work how symbolic refs work I might use one of those!)
 103 sub sfi
 104 {
 105   @_ ? $sfi = shift : $sfi ;
 106 }
 107
 108 sub k
 109 {
 110   @_ ? $k = shift : $k ;
 111 }
 112
 113 sub a
 114 {
 115   @_ ? $a = shift : $a ;
 116 }
 117
 118 sub forecast
 119 {
 120   @_ ? $forecast = shift : $forecast ;
 121 }
 122
 123 1;
 124 __END__;