]> dxcluster.net Git - spider.git/blob - perl/WCY.pm
fix some little problems with disconnects
[spider.git] / perl / WCY.pm
1 #!/usr/bin/perl
2
3 # The WCY analog of the WWV geomagnetic information and calculation module
4 #
5 # Copyright (c) 2000 - Dirk Koopman G1TLH
6 #
7 # $Id$
8 #
9
10 package WCY;
11
12 use DXVars;
13 use DXUtil;
14 use DXLog;
15 use Julian;
16 use IO::File;
17 use DXDebug;
18 use Data::Dumper;
19
20 use strict;
21 use vars qw($date $sfi $k $expk $a $r $sa $gmf $au  @allowed @denied $fp $node $from 
22             $dirprefix $param
23             $duplth $dupage $filterdef);
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 $sa = "";                                               # solar activity
32 $gmf = "";                                              # Geomag activity
33 $au = 'no';                                             # aurora warning
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::data/wcy";
42 $param = "$dirprefix/param";
43
44 $filterdef = bless ([
45                           # tag, sort, field, priv, special parser 
46                           ['by', 'c', 11],
47                           ['origin', 'c', 12],
48                           ['channel', 'n', 13],
49                           ['by_dxcc', 'n', 14],
50                           ['by_itu', 'n', 15],
51                           ['by_zone', 'n', 16],
52                           ['origin_dxcc', 'c', 17],
53                           ['origin_itu', 'c', 18],
54                           ['origin_itu', 'c', 19],
55                          ], 'Filter::Cmd');
56
57
58 sub init
59 {
60         $fp = DXLog::new('wcy', 'dat', 'm');
61         do "$param" if -e "$param";
62         confess $@ if $@;
63 }
64
65 # write the current data away
66 sub store
67 {
68         my $fh = new IO::File;
69         open $fh, "> $param" or confess "can't open $param $!";
70         print $fh "# WCY data parameter file last mod:", scalar gmtime, "\n";
71         my $dd = new Data::Dumper([ $date, $sfi, $a, $k, $expk, $r, $sa, $gmf, $au, $from, $node, \@denied, \@allowed ], [qw(date sfi a k expk r sa gmf au from node *denied *allowed)]);
72         $dd->Indent(1);
73         $dd->Terse(0);
74         $dd->Quotekeys(0);
75         $fh->print($dd->Dumpxs);
76         $fh->close;
77         
78         # log it
79         $fp->writeunix($date, "$date^$sfi^$a^$k^$expk^$r^$sa^$gmf^$au^$from^$node");
80 }
81
82 # update WWV info in one go (usually from a PC23)
83 sub update
84 {
85         my ($mydate, $mytime, $mysfi, $mya, $myk, $myexpk, $myr, $mysa, $mygmf, $myau, $myfrom, $mynode) = @_;
86         if ((@allowed && grep {$_ eq $from} @allowed) || 
87                 (@denied && !grep {$_ eq $from} @denied) ||
88                 (@allowed == 0 && @denied == 0)) {
89                 
90                 #       my $trydate = cltounix($mydate, sprintf("%02d18Z", $mytime));
91                 if ($mydate >= $date) {
92                         if ($myr) {
93                                 $r = 0 + $myr;
94                         } else {
95                                 $r = 0 unless abs ($mysfi - $sfi) > 3;
96                         }
97                         $sfi = $mysfi;
98                         $a = $mya;
99                         $k = $myk;
100                         $expk = $myexpk;
101                         $r = $myr;
102                         $sa = $mysa;
103                         $gmf = $mygmf;
104                         $au = $myau;
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 #
145 # print some items from the log backwards in time
146 #
147 # This command outputs a list of n lines starting from line $from to $to
148 #
149 sub search
150 {
151         my $from = shift;
152         my $to = shift;
153         my @date = $fp->unixtoj(shift);
154         my $pattern = shift;
155         my $search;
156         my @out;
157         my $eval;
158         my $count;
159         
160         $search = 1;
161         $eval = qq(
162                            my \$c;
163                            my \$ref;
164                            for (\$c = \$#in; \$c >= 0; \$c--) {
165                                         \$ref = \$in[\$c];
166                                         if ($search) {
167                                                 \$count++;
168                                                 next if \$count < \$from;
169                                                 push \@out, \$ref;
170                                                 last if \$count >= \$to; # stop after n
171                                         }
172                                 }
173                           );
174         
175         $fp->close;                                     # close any open files
176         
177         my $fh = $fp->open(@date); 
178         for ($count = 0; $count < $to; ) {
179                 my @in = ();
180                 if ($fh) {
181                         while (<$fh>) {
182                                 chomp;
183                                 push @in, [ split '\^' ] if length > 2;
184                         }
185                         eval $eval;                     # do the search on this file
186                         return ("Geomag search error", $@) if $@;
187                         last if $count >= $to; # stop after n
188                 }
189                 $fh = $fp->openprev();  # get the next file
190                 last if !$fh;
191         }
192         
193         return @out;
194 }
195
196 #
197 # the standard log printing interpreting routine.
198 #
199 # every line that is printed should call this routine to be actually visualised
200 #
201 # Don't really know whether this is the correct place to put this stuff, but where
202 # else is correct?
203 #
204 # I get a reference to an array of items
205 #
206 sub print_item
207 {
208         my $r = shift;
209         my $d = cldate($r->[0]);
210         my $t = (gmtime($r->[0]))[2];
211
212         return sprintf("$d   %02d %5d %3d %3d   %3d %3d %-5s %-5s %6s <%s>", 
213                                     $t, @$r[1..9]);
214 }
215
216 #
217 # read in this month's data
218 #
219 sub readfile
220 {
221         my @date = $fp->unixtoj(shift);
222         my $fh = $fp->open(@date); 
223         my @spots = ();
224         my @in;
225         
226         if ($fh) {
227                 while (<$fh>) {
228                         chomp;
229                         push @in, [ split '\^' ] if length > 2;
230                 }
231         }
232         return @in;
233 }
234
235 # enter the spot for dup checking and return true if it is already a dup
236 sub dup
237 {
238         my ($d, $sfi, $a, $k, $r) = @_; 
239
240         # dump if too old
241         return 2 if $d < $main::systime - $dupage;
242  
243         my $dupkey = "C$d|$sfi|$k|$a|$r";
244         return DXDupe::check($dupkey, $main::systime+$dupage);
245 }
246
247 sub listdups
248 {
249         return DXDupe::listdups('C', $dupage, @_);
250 }
251 1;
252 __END__;
253