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