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