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