]> dxcluster.org Git - spider.git/blob - perl/Geomag.pm
put duplicate checking into respective modules and out of DXProt.
[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
20 use strict;
21 use vars qw($date $sfi $k $a $r $forecast @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 $forecast = "";                                 # the current geomagnetic forecast
32 $node = "";                                             # originating node
33 $from = "";                                             # who this came from
34 @allowed = ();                                  # if present only these callsigns are regarded as valid WWV updators
35 @denied = ();                                   # if present ignore any wwv from these callsigns
36 %dup = ();                                              # the spot duplicates hash
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         mkdir $dirprefix, 0777 if !-e $dirprefix; # now unnecessary DXLog will create it
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 "# Geomagnetic data parameter file last mod:", scalar gmtime, "\n";
57         print $fh "\$date = $date;\n";
58         print $fh "\$sfi = $sfi;\n";
59         print $fh "\$a = $a;\n";
60         print $fh "\$k = $k;\n";
61         print $fh "\$r = $r;\n";
62         print $fh "\$from = '$from';\n";
63         print $fh "\$node = '$node';\n";
64         print $fh "\@denied = qw(", join(' ', @denied), ");\n" if @denied > 0;
65         print $fh "\@allowed = qw(", join(' ', @allowed), ");\n" if @allowed > 0;
66         close $fh;
67         
68         # log it
69         $fp->writeunix($date, "$from^$date^$sfi^$a^$k^$forecast^$node^$r");
70 }
71
72 # update WWV info in one go (usually from a PC23)
73 sub update
74 {
75         my ($mydate, $mytime, $mysfi, $mya, $myk, $myforecast, $myfrom, $mynode, $myr) = @_;
76         if ((@allowed && grep {$_ eq $from} @allowed) || 
77                 (@denied && !grep {$_ eq $from} @denied) ||
78                 (@allowed == 0 && @denied == 0)) {
79                 
80                 #       my $trydate = cltounix($mydate, sprintf("%02d18Z", $mytime));
81                 if ($mydate >= $date) {
82                         if ($myr) {
83                                 $r = 0 + $myr;
84                         } else {
85                                 $r = 0 unless abs ($mysfi - $sfi) > 3;
86                         }
87                         $sfi = 0 + $mysfi;
88                         $k = 0 + $myk;
89                         $a = 0 + $mya;
90                         $forecast = $myforecast;
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 # accessor routines (when I work how symbolic refs work I might use one of those!)
131 sub sfi
132 {
133         @_ ? $sfi = shift : $sfi ;
134 }
135
136 sub k
137 {
138         @_ ? $k = shift : $k ;
139 }
140
141 sub r
142 {
143         @_ ? $r = shift : $r ;
144 }
145
146 sub a
147 {
148         @_ ? $a = shift : $a ;
149 }
150
151 sub forecast
152 {
153         @_ ? $forecast = shift : $forecast ;
154 }
155
156
157 #
158 # print some items from the log backwards in time
159 #
160 # This command outputs a list of n lines starting from line $from to $to
161 #
162 sub search
163 {
164         my $from = shift;
165         my $to = shift;
166         my @date = $fp->unixtoj(shift);
167         my $pattern = shift;
168         my $search;
169         my @out;
170         my $eval;
171         my $count;
172         
173         $search = 1;
174         $eval = qq(
175                            my \$c;
176                            my \$ref;
177                            for (\$c = \$#in; \$c >= 0; \$c--) {
178                                         \$ref = \$in[\$c];
179                                         if ($search) {
180                                                 \$count++;
181                                                 next if \$count < \$from;
182                                                 push \@out, \$ref;
183                                                 last if \$count >= \$to; # stop after n
184                                         }
185                                 }
186                           );
187         
188         $fp->close;                                     # close any open files
189         
190         my $fh = $fp->open(@date); 
191         for ($count = 0; $count < $to; ) {
192                 my @in = ();
193                 if ($fh) {
194                         while (<$fh>) {
195                                 chomp;
196                                 push @in, [ split '\^' ] if length > 2;
197                         }
198                         eval $eval;                     # do the search on this file
199                         return ("Geomag search error", $@) if $@;
200                         last if $count >= $to; # stop after n
201                 }
202                 $fh = $fp->openprev();  # get the next file
203                 last if !$fh;
204         }
205         
206         return @out;
207 }
208
209 #
210 # the standard log printing interpreting routine.
211 #
212 # every line that is printed should call this routine to be actually visualised
213 #
214 # Don't really know whether this is the correct place to put this stuff, but where
215 # else is correct?
216 #
217 # I get a reference to an array of items
218 #
219 sub print_item
220 {
221         my $r = shift;
222         my @ref = @$r;
223         my $d = cldate($ref[1]);
224         my ($t) = (gmtime($ref[1]))[2];
225         
226         return sprintf("$d   %02d %5d %3d %3d %-37s <%s>", $t, $ref[2], $ref[3], $ref[4], $ref[5], $ref[0]);
227 }
228
229 #
230 # read in this month's data
231 #
232 sub readfile
233 {
234         my @date = $fp->unixtoj(shift);
235         my $fh = $fp->open(@date); 
236         my @spots = ();
237         my @in;
238         
239         if ($fh) {
240                 while (<$fh>) {
241                         chomp;
242                         push @in, [ split '\^' ] if length > 2;
243                 }
244         }
245         return @in;
246 }
247
248 # enter the spot for dup checking and return true if it is already a dup
249 sub dup
250 {
251         my ($d, $sfi, $k, $a, $text) = @_; 
252
253         # dump if too old
254         return 2 if $d < $main::systime - $dupage;
255  
256         $d /= 60;                            # to the nearest minute
257         chomp $text;
258         $text = substr($text, 0, $duplth) if length $text > $duplth; 
259         my $dupkey = "$d|$sfi|$k|$a|$text";
260         return 1 if exists $dup{$dupkey};
261         $dup{$dupkey} = $d * 60;         # in seconds (to the nearest minute)
262         return 0; 
263 }
264
265 # called every hour and cleans out the dup cache
266 sub process
267 {
268         my $cutoff = $main::systime - $dupage;
269         while (my ($key, $val) = each %dup) {
270                 delete $dup{$key} if $val < $cutoff;
271         }
272 }
273
274 sub listdups
275 {
276         my @out;
277         for (sort { $dup{$a} <=> $dup{$b} } keys %dup) {
278                 my $val = $dup{$_};
279                 push @out, "$_ = $val (" . cldatetime($val) . ")";
280         }
281         return @out;
282 }
283 1;
284 __END__;