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