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