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