perl/WCY.pm

   1 #!/usr/bin/perl
   2 #
   3 # The WCY analog of the WWV geomagnetic information and calculation module
   4 #
   5 # Copyright (c) 2000 - Dirk Koopman G1TLH
   6 #
   7 # $Id$
   8 #
   9
  10 package WCY;
  11
  12 use DXVars;
  13 use DXUtil;
  14 use DXLog;
  15 use Julian;
  16 use IO::File;
  17 use DXDebug;
  18 use Data::Dumper;
  19
  20 use strict;
  21 use vars qw($date $sfi $k $expk $a $r $sa $gmf $au  @allowed @denied $fp $node $from
  22             $dirprefix $param
  23             $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 $sa = "";                                               # solar activity
  32 $gmf = "";                                              # Geomag activity
  33 $au = 'no';                                             # aurora warning
  34 $node = "";                                             # originating node
  35 $from = "";                                             # who this came from
  36 @allowed = ();                                  # if present only these callsigns are regarded as valid WWV updators
  37 @denied = ();                                   # if present ignore any wwv from these callsigns
  38 $duplth = 20;                                   # the length of text to use in the deduping
  39 $dupage = 12*3600;                              # the length of time to hold spot dups
  40
  41 $dirprefix = "$main::data/wcy";
  42 $param = "$dirprefix/param";
  43
  44 sub init
  45 {
  46         $fp = DXLog::new('wcy', 'dat', 'm');
  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 "# WCY data parameter file last mod:", scalar gmtime, "\n";
  57         my $dd = new Data::Dumper([ $date, $sfi, $a, $k, $expk, $r, $sa, $gmf, $au, $from, $node, \@denied, \@allowed ], [qw(date sfi a k expk r sa gmf au from node *denied *allowed)]);
  58         $dd->Indent(1);
  59         $dd->Terse(0);
  60         $dd->Quotekeys(0);
  61         $fh->print($dd->Dumpxs);
  62         $fh->close;
  63
  64         # log it
  65         $fp->writeunix($date, "$date^$sfi^$a^$k^$expk^$r^$sa^$gmf^$au^$from^$node");
  66 }
  67
  68 # update WWV info in one go (usually from a PC23)
  69 sub update
  70 {
  71         my ($mydate, $mytime, $mysfi, $mya, $myk, $myexpk, $myr, $mysa, $mygmf, $myau, $myfrom, $mynode) = @_;
  72         if ((@allowed && grep {$_ eq $from} @allowed) ||
  73                 (@denied && !grep {$_ eq $from} @denied) ||
  74                 (@allowed == 0 && @denied == 0)) {
  75
  76                 #       my $trydate = cltounix($mydate, sprintf("%02d18Z", $mytime));
  77                 if ($mydate >= $date) {
  78                         if ($myr) {
  79                                 $r = 0 + $myr;
  80                         } else {
  81                                 $r = 0 unless abs ($mysfi - $sfi) > 3;
  82                         }
  83                         $sfi = $mysfi;
  84                         $a = $mya;
  85                         $k = $myk;
  86                         $expk = $myexpk;
  87                         $r = $myr;
  88                         $sa = $mysa;
  89                         $gmf = $mygmf;
  90                         $au = $myau;
  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 #
 131 # print some items from the log backwards in time
 132 #
 133 # This command outputs a list of n lines starting from line $from to $to
 134 #
 135 sub search
 136 {
 137         my $from = shift;
 138         my $to = shift;
 139         my @date = $fp->unixtoj(shift);
 140         my $pattern = shift;
 141         my $search;
 142         my @out;
 143         my $eval;
 144         my $count;
 145
 146         $search = 1;
 147         $eval = qq(
 148                            my \$c;
 149                            my \$ref;
 150                            for (\$c = \$#in; \$c >= 0; \$c--) {
 151                                         \$ref = \$in[\$c];
 152                                         if ($search) {
 153                                                 \$count++;
 154                                                 next if \$count < \$from;
 155                                                 push \@out, \$ref;
 156                                                 last if \$count >= \$to; # stop after n
 157                                         }
 158                                 }
 159                           );
 160
 161         $fp->close;                                     # close any open files
 162
 163         my $fh = $fp->open(@date);
 164         for ($count = 0; $count < $to; ) {
 165                 my @in = ();
 166                 if ($fh) {
 167                         while (<$fh>) {
 168                                 chomp;
 169                                 push @in, [ split '\^' ] if length > 2;
 170                         }
 171                         eval $eval;                     # do the search on this file
 172                         return ("Geomag search error", $@) if $@;
 173                         last if $count >= $to; # stop after n
 174                 }
 175                 $fh = $fp->openprev();  # get the next file
 176                 last if !$fh;
 177         }
 178
 179         return @out;
 180 }
 181
 182 #
 183 # the standard log printing interpreting routine.
 184 #
 185 # every line that is printed should call this routine to be actually visualised
 186 #
 187 # Don't really know whether this is the correct place to put this stuff, but where
 188 # else is correct?
 189 #
 190 # I get a reference to an array of items
 191 #
 192 sub print_item
 193 {
 194         my $r = shift;
 195         my $d = cldate($r->[0]);
 196         my $t = (gmtime($r->[0]))[2];
 197
 198         return sprintf("$d   %02d %5d %3d %3d   %3d %3d %-5s %-5s %6s <%s>",
 199                                     $t, @$r[1..9]);
 200 }
 201
 202 #
 203 # read in this month's data
 204 #
 205 sub readfile
 206 {
 207         my @date = $fp->unixtoj(shift);
 208         my $fh = $fp->open(@date);
 209         my @spots = ();
 210         my @in;
 211
 212         if ($fh) {
 213                 while (<$fh>) {
 214                         chomp;
 215                         push @in, [ split '\^' ] if length > 2;
 216                 }
 217         }
 218         return @in;
 219 }
 220
 221 # enter the spot for dup checking and return true if it is already a dup
 222 sub dup
 223 {
 224         my ($d, $sfi, $a, $k, $r) = @_;
 225
 226         # dump if too old
 227         return 2 if $d < $main::systime - $dupage;
 228
 229         my $dupkey = "C$d|$sfi|$k|$a|$r";
 230         return DXDupe::check($dupkey, $main::systime+$dupage);
 231 }
 232
 233 sub listdups
 234 {
 235         return DXDupe::listdups('C', $dupage, @_);
 236 }
 237 1;
 238 __END__;
 239