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