]> scm.dxcluster.org Git - spider.git/blob - perl/DXProt.pm
710a3dbf84129a4b0405fc92597c8ff2cd7e2161
[spider.git] / perl / DXProt.pm
1 #!/usr/bin/perl
2 #
3 # This module impliments the protocal mode for a dx cluster
4 #
5 # Copyright (c) 1998 Dirk Koopman G1TLH
6 #
7 # $Id$
8
9
10 package DXProt;
11
12 @ISA = qw(DXChannel);
13
14 use DXUtil;
15 use DXChannel;
16 use DXUser;
17 use DXM;
18 use DXCluster;
19 use DXProtVars;
20 use DXCommandmode;
21 use DXLog;
22 use Spot;
23 use DXProtout;
24 use DXDebug;
25 use Filter;
26 use Local;
27 use DXDb;
28 use Time::HiRes qw(gettimeofday tv_interval);
29
30 use Carp;
31
32 use strict;
33 use vars qw($me $pc11_max_age $pc23_max_age $pc11_dup_age $pc23_dup_age
34                         %spotdup %wwvdup $last_hour %pings %rcmds
35                         %nodehops @baddx $baddxfn $pc12_dup_age
36                         %anndup $allowzero $pc12_dup_lth $decode_dk0wcy);
37
38 $me = undef;                                    # the channel id for this cluster
39 $decode_dk0wcy = undef;                 # if set use this callsign to decode announces from the EU WWV data beacon
40 $pc11_max_age = 1*3600;                 # the maximum age for an incoming 'real-time' pc11
41 $pc23_max_age = 1*3600;                 # the maximum age for an incoming 'real-time' pc23
42 $pc11_dup_age = 3*3600;                 # the maximum time to keep the spot dup list for
43 $pc23_dup_age = 3*3600;                 # the maximum time to keep the wwv dup list for
44 $pc12_dup_age = 24*3600;                # the maximum time to keep the ann dup list for
45 $pc12_dup_lth = 60;                             # the length of ANN text to save for deduping 
46 %spotdup = ();                              # the pc11 and 26 dup hash 
47 %wwvdup = ();                               # the pc23 and 27 dup hash
48 %anndup = ();                               # the PC12 dup hash
49 $last_hour = time;                              # last time I did an hourly periodic update
50 %pings = ();                    # outstanding ping requests outbound
51 %rcmds = ();                    # outstanding rcmd requests outbound
52 %nodehops = ();                 # node specific hop control
53 @baddx = ();                    # list of illegal spotted callsigns
54
55
56 $baddxfn = "$main::data/baddx.pl";
57
58 sub init
59 {
60         my $user = DXUser->get($main::mycall);
61         $DXProt::myprot_version += $main::version*100;
62         $me = DXProt->new($main::mycall, 0, $user); 
63         $me->{here} = 1;
64         $me->{state} = "indifferent";
65         do "$main::data/hop_table.pl" if -e "$main::data/hop_table.pl";
66         confess $@ if $@;
67         #  $me->{sort} = 'M';    # M for me
68
69         # now prime the spot duplicates file with today's and yesterday's data
70     my @today = Julian::unixtoj(time);
71         my @spots = Spot::readfile(@today);
72         @today = Julian::sub(@today, 1);
73         push @spots, Spot::readfile(@today);
74         for (@spots) {
75                 my $dupkey = "$_->[0]$_->[1]$_->[2]$_->[3]$_->[4]";
76                 $spotdup{$dupkey} = $_->[2];
77         }
78
79         # now prime the wwv duplicates file with just this month's data
80         my @wwv = Geomag::readfile(time);
81         for (@wwv) {
82                 my $dupkey = "$_->[1].$_->[2]$_->[3]$_->[4]";
83                 $wwvdup{$dupkey} = $_->[1];
84         }
85
86         # load the baddx file
87         do "$baddxfn" if -e "$baddxfn";
88         print "$@\n" if $@;
89 }
90
91 #
92 # obtain a new connection this is derived from dxchannel
93 #
94
95 sub new 
96 {
97         my $self = DXChannel::alloc(@_);
98         $self->{'sort'} = 'A';          # in absence of how to find out what sort of an object I am
99         return $self;
100 }
101
102 # this is how a pc connection starts (for an incoming connection)
103 # issue a PC38 followed by a PC18, then wait for a PC20 (remembering
104 # all the crap that comes between).
105 sub start
106 {
107         my ($self, $line, $sort) = @_;
108         my $call = $self->{call};
109         my $user = $self->{user};
110         
111         # remember type of connection
112         $self->{consort} = $line;
113         $self->{outbound} = $sort eq 'O';
114         $self->{priv} = $user->priv;
115         $self->{lang} = $user->lang;
116         $self->{isolate} = $user->{isolate};
117         $self->{consort} = $line;       # save the connection type
118         $self->{here} = 1;
119
120         # get the INPUT filters (these only pertain to Clusters)
121         $self->{inspotfilter} = Filter::read_in('spots', $call, 1);
122         $self->{inwwvfilter} = Filter::read_in('wwv', $call, 1);
123         $self->{inannfilter} = Filter::read_in('ann', $call, 1);
124         
125         # set unbuffered and no echo
126         $self->send_now('B',"0");
127         $self->send_now('E',"0");
128         
129         # ping neighbour node stuff
130         my $ping = $user->pingint;
131         $ping = 5*60 unless defined $ping;
132         $self->{pingint} = $ping;
133         $self->{nopings} = $user->nopings || 2;
134         $self->{pingtime} = [ ];
135         $self->{pingave} = 0;
136
137         # send initialisation string
138         unless ($self->{outbound}) {
139                 $self->send(pc38()) if DXNode->get_all();
140                 $self->send(pc18());
141                 $self->{lastping} = $main::systime;
142         } else {
143                 # remove from outstanding connects queue
144                 @main::outstanding_connects = grep {$_->{call} ne $call} @main::outstanding_connects;
145                 $self->{lastping} = $main::systime + $self->pingint / 2;
146         }
147         $self->state('init');
148         $self->pc50_t(time);
149
150         # send info to all logged in thingies
151         $self->tell_login('loginn');
152
153         Log('DXProt', "$call connected");
154 }
155
156 #
157 # This is the normal pcxx despatcher
158 #
159 sub normal
160 {
161         my ($self, $line) = @_;
162         my @field = split /\^/, $line;
163         pop @field if $field[-1] eq '~';
164         
165 #       print join(',', @field), "\n";
166                                                 
167         # ignore any lines that don't start with PC
168         return if !$field[0] =~ /^PC/;
169         
170         # process PC frames
171         my ($pcno) = $field[0] =~ /^PC(\d\d)/; # just get the number
172         return unless $pcno;
173         return if $pcno < 10 || $pcno > 51;
174
175         # dump bad protocol messages unless it is a PC29
176         if ($line =~ /\%[0-9A-F][0-9A-F]/o && $pcno != 29) {
177                 dbg('chan', "CORRUPT protocol message - dumped");
178                 return;
179         }
180
181         # local processing 1
182         my $pcr;
183         eval {
184                 $pcr = Local::pcprot($self, $pcno, @field);
185         };
186 #       dbg('local', "Local::pcprot error $@") if $@;
187         return if $pcr;
188         
189  SWITCH: {
190                 if ($pcno == 10) {              # incoming talk
191                         
192                         # is it for me or one of mine?
193                         my $call = ($field[5] gt ' ') ? $field[5] : $field[2];
194                         if ($call eq $main::mycall || grep $_ eq $call, DXChannel::get_all_user_calls()) {
195                                 
196                                 # yes, it is
197                                 my $text = unpad($field[3]);
198                                 Log('talk', $call, $field[1], $field[6], $text);
199                                 $call = $main::myalias if $call eq $main::mycall;
200                                 my $ref = DXChannel->get($call);
201                                 $ref->send("$call de $field[1]: $text") if $ref && $ref->{talk};
202                         } else {
203                                 $self->route($field[2], $line); # relay it on its way
204                         }
205                         return;
206                 }
207                 
208                 if ($pcno == 11 || $pcno == 26) { # dx spot
209
210                         # route 'foreign' pc26s 
211                         if ($pcno == 26) {
212                                 if ($field[7] ne $main::mycall) {
213                                         $self->route($field[7], $line);
214                                         return;
215                                 }
216                         }
217                         
218                         # if this is a 'nodx' node then ignore it
219                         if (grep $field[7] =~ /^$_/,  @DXProt::nodx_node) {
220                                 dbg('chan', "Bad DXNode, dropped");
221                                 return;
222                         }
223                         
224                         # convert the date to a unix date
225                         my $d = cltounix($field[3], $field[4]);
226                         # bang out (and don't pass on) if date is invalid or the spot is too old (or too young)
227                         if (!$d || ($pcno == 11 && ($d < $main::systime - $pc11_max_age || $d > $main::systime + 900))) {
228                                 dbg('chan', "Spot ignored, invalid date or out of range ($field[3] $field[4])\n");
229                                 return;
230                         }
231
232                         # strip off the leading & trailing spaces from the comment
233                         my $text = unpad($field[5]);
234                         
235                         # store it away
236                         my $spotter = $field[6];
237                         $spotter =~ s/-[\@\d]+$//o;     # strip off the ssid from the spotter
238                         
239                         # do some de-duping
240                         my $freq = $field[1] - 0;
241                         my $dupkey = "$freq$field[2]$d$text$spotter";
242                         if ($spotdup{$dupkey}) {
243                                 dbg('chan', "Duplicate Spot ignored\n");
244                                 return;
245                         }
246                         
247                         $spotdup{$dupkey} = $d;
248
249                         # is it 'baddx'
250                         if (grep $field[2] eq $_, @baddx) {
251                                 dbg('chan', "Bad DX spot, ignored");
252                                 return;
253                         }
254
255                         # are any of the crucial fields invalid?
256             if ($field[2] =~ /[a-z]/ || $field[6] =~ /[a-z]/ || $field[7] =~ /[a-z]/) {
257                                 dbg('chan', "Spot contains lower case callsigns, rejected");
258                                 return;
259                         }
260                         
261                         my @spot = Spot::add($freq, $field[2], $d, $text, $spotter, $field[7]);
262
263             #
264                         # @spot at this point contains:-
265             # freq, spotted call, time, text, spotter, spotted cc, spotters cc, orig node
266                         # then  spotted itu, spotted cq, spotters itu, spotters cq
267                         # you should be able to route on any of these
268             #
269                         
270                         # local processing 
271                         my $r;
272                         eval {
273                                 $r = Local::spot($self, @spot);
274                         };
275 #                       dbg('local', "Local::spot1 error $@") if $@;
276                         return if $r;
277
278                         # DON'T be silly and send on PC26s!
279                         return if $pcno == 26;
280
281                         # send out the filtered spots
282                         send_dx_spot($self, $line, @spot) if @spot;
283                         return;
284                 }
285                 
286                 if ($pcno == 12) {              # announces
287                         # announce duplicate checking
288                         my $text = substr(uc unpad($field[3]), 0, $pc12_dup_lth);
289                         my $dupkey = $field[1].$field[2].$text;
290                         if ($anndup{$dupkey}) {
291                                 dbg('chan', "Duplicate Announce ignored\n");
292                                 return;
293                         }
294                         $anndup{$dupkey} = $main::systime;
295                         
296                         if ($field[2] eq '*' || $field[2] eq $main::mycall) {
297                                 
298                                 # global ann filtering on INPUT
299                                 if ($self->{inannfilter}) {
300                                         my ($filter, $hops) = Filter::it($self->{inannfilter}, @field[1..6], $self->{call} );
301                                         unless ($filter) {
302                                                 dbg('chan', "Rejected by filter");
303                                                 return;
304                                         }
305                                 }
306
307                                 # send it
308                                 $self->send_announce($line, @field[1..6]);
309                                 
310                                 if ($decode_dk0wcy && $field[1] eq $decode_dk0wcy) {
311                                         my ($hour, $k, $next, $a, $r, $sfi, $alarm) = $field[3] =~ /^Aurora Beacon\s+(\d+)UTC,\s+Kiel\s+K=(\d+),.*ed\s+K=(\d+),\s+A=(\d+),\s+R=(\d+),\s+SFI=(\d+),.*larm:\s+(\w+)/;
312                                         $alarm = ($alarm =~ /^Y/i) ? ', Aurora in DE' : ''; 
313                                         my $wwv = Geomag::update($main::systime, $hour, $sfi, $a, $k, "R=$r, Next K=$next$alarm", $decode_dk0wcy, $field[5], $r) if $sfi && $r;
314                                 }
315                                 
316                         } else {
317                                 $self->route($field[2], $line);
318                         }
319                         
320                         return;
321                 }
322                 
323                 if ($pcno == 13) {
324                         last SWITCH;
325                 }
326                 if ($pcno == 14) {
327                         last SWITCH;
328                 }
329                 if ($pcno == 15) {
330                         last SWITCH;
331                 }
332                 
333                 if ($pcno == 16) {              # add a user
334                         my $node = DXCluster->get_exact($field[1]); 
335                         my $dxchan;
336                         if (!$node && ($dxchan = DXChannel->get($field[1]))) {
337                                 # add it to the node table if it isn't present and it's
338                                 # connected locally
339                                 $node = DXNode->new($dxchan, $field[1], 0, 1, 5400);
340                                 broadcast_ak1a(pc19($dxchan, $node), $dxchan, $self) unless $dxchan->{isolate};
341                                 
342                         }
343                         return unless $node; # ignore if havn't seen a PC19 for this one yet
344                         return unless $node->isa('DXNode');
345                         if ($node->dxchan != $self) {
346                                 dbg('chan', "LOOP: $field[1] came in on wrong channel");
347                                 return;
348                         }
349                         if (($dxchan = DXChannel->get($field[1])) && $dxchan != $self) {
350                                 dbg('chan', "LOOP: $field[1] connected locally");
351                                 return;
352                         }
353                         my $i;
354                                                 
355                         for ($i = 2; $i < $#field; $i++) {
356                                 my ($call, $confmode, $here) = $field[$i] =~ /^(\S+) (\S) (\d)/o;
357                                 next if !$call || length $call < 3 || length $call > 8;
358                                 next if !$confmode;
359                                 $call = uc $call;
360                                 next if DXCluster->get_exact($call); # we already have this (loop?)
361                                 
362                                 $confmode = $confmode eq '*';
363                                 DXNodeuser->new($self, $node, $call, $confmode, $here);
364                                 
365                                 # add this station to the user database, if required
366                                 $call =~ s/-\d+$//o;        # remove ssid for users
367                                 my $user = DXUser->get_current($call);
368                                 $user = DXUser->new($call) if !$user;
369                                 $user->homenode($node->call) if !$user->homenode;
370                                 $user->node($node->call);
371                                 $user->lastin($main::systime) unless DXChannel->get($call);
372                                 $user->put;
373                         }
374                         
375                         # queue up any messages (look for privates only)
376                         DXMsg::queue_msg(1) if $self->state eq 'normal';     
377                         last SWITCH;
378                 }
379                 
380                 if ($pcno == 17) {              # remove a user
381                         my $node = DXCluster->get_exact($field[2]);
382                         my $dxchan;
383                         if (!$node && ($dxchan = DXChannel->get($field[2]))) {
384                                 # add it to the node table if it isn't present and it's
385                                 # connected locally
386                                 $node = DXNode->new($dxchan, $field[2], 0, 1, 5400);
387                                 broadcast_ak1a(pc19($dxchan, $node), $dxchan, $self) unless $dxchan->{isolate};
388                                 return;
389                         }
390                         return unless $node;
391                         return unless $node->isa('DXNode');
392                         if ($node->dxchan != $self) {
393                                 dbg('chan', "LOOP: $field[2] came in on wrong channel");
394                                 return;
395                         }
396                         if (($dxchan = DXChannel->get($field[2])) && $dxchan != $self) {
397                                 dbg('chan', "LOOP: $field[2] connected locally");
398                                 return;
399                         }
400                         my $ref = DXCluster->get_exact($field[1]);
401                         $ref->del() if $ref;
402                         last SWITCH;
403                 }
404                 
405                 if ($pcno == 18) {              # link request
406                         $self->state('init');   
407
408                         # first clear out any nodes on this dxchannel
409                         my @gonenodes = map { $_->dxchan == $self ? $_ : () } DXNode::get_all();
410                         foreach my $node (@gonenodes) {
411                                 next if $node->dxchan == $DXProt::me;
412                                 broadcast_ak1a(pc21($node->call, 'Gone, re-init') , $self) unless $self->{isolate}; 
413                                 $node->del();
414                         }
415                         $self->send_local_config();
416                         $self->send(pc20());
417                         return;             # we don't pass these on
418                 }
419                 
420                 if ($pcno == 19) {              # incoming cluster list
421                         my $i;
422                         my $newline = "PC19^";
423                         for ($i = 1; $i < $#field-1; $i += 4) {
424                                 my $here = $field[$i];
425                                 my $call = uc $field[$i+1];
426                                 my $confmode = $field[$i+2];
427                                 my $ver = $field[$i+3];
428
429                                 $ver = 5400 if !$ver && $allowzero;
430                                 
431                                 # now check the call over
432                                 my $node = DXCluster->get_exact($call);
433                                 if ($node) {
434                                         my $dxchan;
435                                         if (($dxchan = DXChannel->get($call)) && $dxchan != $self) {
436                                                 dbg('chan', "LOOP: $call connected locally");
437                                         }
438                                     if ($node->dxchan != $self) {
439                                                 dbg('chan', "LOOP: $call come in on wrong channel");
440                                                 next;
441                                         }
442                                         dbg('chan', "already have $call");
443                                         next;
444                                 }
445                                 
446                                 # check for sane parameters
447                                 next if $ver < 5000; # only works with version 5 software
448                                 next if length $call < 3; # min 3 letter callsigns
449
450                                 # add it to the nodes table and outgoing line
451                                 $newline .= "$here^$call^$confmode^$ver^";
452                                 DXNode->new($self, $call, $confmode, $here, $ver);
453                                 
454                                 # unbusy and stop and outgoing mail (ie if somehow we receive another PC19 without a disconnect)
455                                 my $mref = DXMsg::get_busy($call);
456                                 $mref->stop_msg($call) if $mref;
457                                 
458                                 # add this station to the user database, if required (don't remove SSID from nodes)
459                                 my $user = DXUser->get_current($call);
460                                 if (!$user) {
461                                         $user = DXUser->new($call);
462                                         $user->sort('A');
463                                         $user->priv(1);                   # I have relented and defaulted nodes
464                                         $self->{priv} = 1;                # to user RCMDs allowed
465                                         $user->homenode($call);
466                                         $user->node($call);
467                                 }
468                                 $user->lastin($main::systime) unless DXChannel->get($call);
469                                 $user->put;
470                         }
471                         
472                         return if $newline eq "PC19^";
473
474                         # add hop count 
475                         $newline .=  get_hops(19) . "^";
476                         $line = $newline;
477                         last SWITCH;
478                 }
479                 
480                 if ($pcno == 20) {              # send local configuration
481                         $self->send_local_config();
482                         $self->send(pc22());
483                         $self->state('normal');
484                         return;
485                 }
486                 
487                 if ($pcno == 21) {              # delete a cluster from the list
488                         my $call = uc $field[1];
489                         if ($call ne $main::mycall) { # don't allow malicious buggers to disconnect me!
490                                 my $node = DXCluster->get_exact($call);
491                                 if ($node) {
492                                         if ($node->dxchan != $self) {
493                                                 dbg('chan', "LOOP: $call come in on wrong channel");
494                                                 return;
495                                         }
496                                         my $dxchan;
497                                         if (($dxchan = DXChannel->get($call)) && $dxchan != $self) {
498                                                 dbg('chan', "LOOP: $call connected locally");
499                                                 return;
500                                         }
501                                         $node->del();
502                                 } else {
503                                         dbg('chan', "$call not in table, dropped");
504                                         return;
505                                 }
506                         }
507                         last SWITCH;
508                 }
509                 
510                 if ($pcno == 22) {
511                         $self->state('normal');
512                         return;
513                 }
514                                 
515                 if ($pcno == 23 || $pcno == 27) { # WWV info
516                         
517                         # route 'foreign' pc27s 
518                         if ($pcno == 27) {
519                                 if ($field[8] ne $main::mycall) {
520                                         $self->route($field[8], $line);
521                                         return;
522                                 }
523                         }
524
525                         # do some de-duping
526                         my $d = cltounix($field[1], sprintf("%02d18Z", $field[2]));
527                         my $sfi = unpad($field[3]);
528                         my $k = unpad($field[4]);
529                         my $i = unpad($field[5]);
530                         my ($r) = $field[6] =~ /R=(\d+)/;
531                         $r = 0 unless $r;
532                         my $dupkey = "$d.$sfi$k$i";
533                         if ($wwvdup{$dupkey}) {
534                                 dbg('chan', "Dup WWV Spot ignored\n");
535                                 return;
536                         }
537                         if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $field[2] < 0 || $field[2] > 23) {
538                                 dbg('chan', "WWV Date ($field[1] $field[2]) out of range");
539                                 return;
540                         }
541                         $wwvdup{$dupkey} = $d;
542                         $field[6] =~ s/-\d+$//o;            # remove spotter's ssid
543                 
544                         my $wwv = Geomag::update($d, $field[2], $sfi, $k, $i, @field[6..8], $r);
545
546                         my $rep;
547                         eval {
548                                 $rep = Local::wwv($self, $field[1], $field[2], $sfi, $k, $i, @field[6..8], $r);
549                         };
550 #                       dbg('local', "Local::wwv2 error $@") if $@;
551                         return if $rep;
552
553                         # DON'T be silly and send on PC27s!
554                         return if $pcno == 27;
555
556                         # broadcast to the eager world
557                         send_wwv_spot($self, $line, $d, $field[2], $sfi, $k, $i, @field[6..8]);
558                         return;
559                 }
560                 
561                 if ($pcno == 24) {              # set here status
562                         my $call = uc $field[1];
563                         my $ref = DXCluster->get_exact($call);
564                         $ref->here($field[2]) if $ref;
565                         last SWITCH;
566                 }
567                 
568                 if ($pcno == 25) {      # merge request
569                         if ($field[1] ne $main::mycall) {
570                                 $self->route($field[1], $line);
571                                 return;
572                         }
573                         if ($field[2] eq $main::mycall) {
574                                 dbg('chan', "Trying to merge to myself, ignored");
575                                 return;
576                         }
577
578                         Log('DXProt', "Merge request for $field[3] spots and $field[4] WWV from $field[1]");
579                         
580                         # spots
581                         if ($field[3] > 0) {
582                                 my @in = reverse Spot::search(1, undef, undef, 0, $field[3]);
583                                 my $in;
584                                 foreach $in (@in) {
585                                         $self->send(pc26(@{$in}[0..4], $field[2]));
586                                 }
587                         }
588
589                         # wwv
590                         if ($field[4] > 0) {
591                                 my @in = reverse Geomag::search(0, $field[4], time, 1);
592                                 my $in;
593                                 foreach $in (@in) {
594                                         $self->send(pc27(@{$in}[0..5], $field[2]));
595                                 }
596                         }
597                         return;
598                 }
599
600                 if (($pcno >= 28 && $pcno <= 33) || $pcno == 40 || $pcno == 42 || $pcno == 49) { # mail/file handling
601                         if ($pcno == 49 || $field[1] eq $main::mycall) {
602                                 DXMsg::process($self, $line);
603                         } else {
604                                 $self->route($field[1], $line);
605                         }
606                         return;
607                 }
608                 
609                 if ($pcno == 34 || $pcno == 36) { # remote commands (incoming)
610                         if ($field[1] eq $main::mycall) {
611                                 my $ref = DXUser->get_current($field[2]);
612                                 my $cref = DXCluster->get($field[2]);
613                                 Log('rcmd', 'in', $ref->{priv}, $field[2], $field[3]);
614                                 unless ($field[3] =~ /rcmd/i || !$cref || !$ref || $cref->mynode->call ne $ref->homenode) {    # not allowed to relay RCMDS!
615                                         if ($ref->{priv}) {     # you have to have SOME privilege, the commands have further filtering
616                                                 $self->{remotecmd} = 1; # for the benefit of any command that needs to know
617                                                 my $oldpriv = $self->{priv};
618                                                 $self->{priv} = $ref->{priv};     # assume the user's privilege level
619                                                 my @in = (DXCommandmode::run_cmd($self, $field[3]));
620                                                 $self->{priv} = $oldpriv;
621                                                 for (@in) {
622                                                         s/\s*$//og;
623                                                         $self->send(pc35($main::mycall, $field[2], "$main::mycall:$_"));
624                                                         Log('rcmd', 'out', $field[2], $_);
625                                                 }
626                                                 delete $self->{remotecmd};
627                                         } else {
628                                                 $self->send(pc35($main::mycall, $field[2], "$main::mycall:sorry...!"));
629                                         }
630                                 } else {
631                                         $self->send(pc35($main::mycall, $field[2], "$main::mycall:your attempt is logged, Tut tut tut...!"));
632                                 }
633                         } else {
634                                 $self->route($field[1], $line);
635                         }
636                         return;
637                 }
638                 
639                 if ($pcno == 35) {              # remote command replies
640                         if ($field[1] eq $main::mycall) {
641                                 my $s = $rcmds{$field[2]};
642                                 if ($s) {
643                                         my $dxchan = DXChannel->get($s->{call});
644                                         $dxchan->send($field[3]) if $dxchan;
645                                         delete $rcmds{$field[2]} if !$dxchan;
646                                 }
647                         } else {
648                                 $self->route($field[1], $line);
649                         }
650                         return;
651                 }
652                 
653                 # for pc 37 see 44 onwards
654
655                 if ($pcno == 38) {              # node connected list from neighbour
656                         return;
657                 }
658                 
659                 if ($pcno == 39) {              # incoming disconnect
660                         $self->disconnect();
661                         return;
662                 }
663                 
664                 if ($pcno == 41) {              # user info
665                         # add this station to the user database, if required
666                         my $user = DXUser->get_current($field[1]);
667                         if (!$user) {
668                                 # then try without an SSID
669                                 $field[1] =~ s/-\d+$//o;
670                                 $user = DXUser->get_current($field[1]);
671                         }
672                         $user = DXUser->new($field[1]) if !$user;
673                         
674                         if ($field[2] == 1) {
675                                 $user->name($field[3]);
676                         } elsif ($field[2] == 2) {
677                                 $user->qth($field[3]);
678                         } elsif ($field[2] == 3) {
679                                 my ($lat, $long) = DXBearing::stoll($field[3]);
680                                 $user->lat($lat);
681                                 $user->long($long);
682                         } elsif ($field[2] == 4) {
683                                 $user->homenode($field[3]);
684                         }
685                         $user->put;
686                         last SWITCH;
687                 }
688                 if ($pcno == 43) {
689                         last SWITCH;
690                 }
691                 if ($pcno == 37 || $pcno == 44 || $pcno == 45 || $pcno == 46 || $pcno == 47) {
692                         DXDb::process($self, $line);
693                         return;
694                 }
695                 
696                 if ($pcno == 50) {              # keep alive/user list
697                         my $node = DXCluster->get_exact($field[1]);
698                         if ($node) {
699                                 return unless $node->isa('DXNode');
700                                 return unless $node->dxchan == $self;
701                                 $node->update_users($field[2]);
702                         }
703                         last SWITCH;
704                 }
705                 
706                 if ($pcno == 51) {              # incoming ping requests/answers
707                         
708                         # is it for us?
709                         if ($field[1] eq $main::mycall) {
710                                 my $flag = $field[3];
711                                 if ($flag == 1) {
712                                         $self->send(pc51($field[2], $field[1], '0'));
713                                 } else {
714                                         # it's a reply, look in the ping list for this one
715                                         my $ref = $pings{$field[2]};
716                                         if ($ref) {
717                                                 my $tochan =  DXChannel->get($field[2]);
718                                                 while (@$ref) {
719                                                         my $r = shift @$ref;
720                                                         my $dxchan = DXChannel->get($r->{call});
721                                                         next unless $dxchan;
722                                                         my $t = tv_interval($r->{t}, [ gettimeofday ]);
723                                                         if ($dxchan->is_user) {
724                                                                 my $s = sprintf "%.2f", $t; 
725                                                                 my $ave = sprintf "%.2f", $tochan ? ($tochan->{pingave} || $t) : $t;
726                                                                 $dxchan->send($dxchan->msg('pingi', $field[2], $s, $ave))
727                                                         } elsif ($dxchan->is_ak1a) {
728                                                                 if ($tochan) {
729                                                                         $tochan->{nopings} = 2; # pump up the timer
730                                                                         push @{$tochan->{pingtime}}, $t;
731                                                                         shift @{$tochan->{pingtime}} if @{$tochan->{pingtime}} > 6;
732                                                                         my $st;
733                                                                         for (@{$tochan->{pingtime}}) {
734                                                                                 $st += $_;
735                                                                         }
736                                                                         $tochan->{pingave} = $st / @{$tochan->{pingtime}};
737                                                                 }
738                                                         } 
739                                                 }
740                                         }
741                                 }
742                         } else {
743                                 # route down an appropriate thingy
744                                 $self->route($field[1], $line);
745                         }
746                         return;
747                 }
748         }
749          
750          # if get here then rebroadcast the thing with its Hop count decremented (if
751          # there is one). If it has a hop count and it decrements to zero then don't
752          # rebroadcast it.
753          #
754          # NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be
755          #        REBROADCAST!!!!
756          #
757          
758         unless ($self->{isolate}) {
759                 broadcast_ak1a($line, $self); # send it to everyone but me
760         }
761 }
762
763 #
764 # This is called from inside the main cluster processing loop and is used
765 # for despatching commands that are doing some long processing job
766 #
767 sub process
768 {
769         my $t = time;
770         my @dxchan = DXChannel->get_all();
771         my $dxchan;
772         
773         foreach $dxchan (@dxchan) {
774                 next unless $dxchan->is_ak1a();
775                 next if $dxchan == $me;
776                 
777                 # send a pc50 out on this channel
778                 if ($t >= $dxchan->pc50_t + $DXProt::pc50_interval) {
779                         $dxchan->send(pc50());
780                         $dxchan->pc50_t($t);
781                 } 
782
783                 # send a ping out on this channel
784                 if ($dxchan->{pingint} && $t >= $dxchan->{pingint} + $dxchan->{lastping}) {
785                         if ($dxchan->{nopings} <= 0) {
786                                 $dxchan->disconnect;
787                         } else {
788                                 addping($main::mycall, $dxchan->call);
789                                 $dxchan->{nopings} -= 1;
790                                 $dxchan->{lastping} = $t;
791                         }
792                 }
793         }
794         
795         my $key;
796         my $val;
797         my $cutoff;
798         if ($main::systime - 3600 > $last_hour) {
799                 $cutoff  = $main::systime - $pc11_dup_age;
800                 while (($key, $val) = each %spotdup) {
801                         delete $spotdup{$key} if $val < $cutoff;
802                 }
803                 $cutoff = $main::systime - $pc23_dup_age;
804                 while (($key, $val) = each %wwvdup) {
805                         delete $wwvdup{$key} if $val < $cutoff;
806                 }
807                 $cutoff = $main::systime - $pc12_dup_age;
808                 while (($key, $val) = each %anndup) {
809                         delete $anndup{$key} if $val < $cutoff;
810                 }
811                 $last_hour = $main::systime;
812         }
813 }
814
815 #
816 # finish up a pc context
817 #
818 sub finish
819 {
820         my $self = shift;
821         my $call = $self->call;
822         my $nopc39 = shift;
823         my $ref = DXCluster->get_exact($call);
824         
825         $self->send_now("D", DXProt::pc39($main::mycall, $self->msg('disc1', "System Op"))) unless $nopc39;
826         
827         # unbusy and stop and outgoing mail
828         my $mref = DXMsg::get_busy($call);
829         $mref->stop_msg($call) if $mref;
830         
831         # broadcast to all other nodes that all the nodes connected to via me are gone
832         my @gonenodes = map { $_->dxchan == $self ? $_ : () } DXNode::get_all();
833         my $node;
834         
835         foreach $node (@gonenodes) {
836                 next if $node->call eq $call;
837                 broadcast_ak1a(pc21($node->call, 'Gone') , $self) unless $self->{isolate}; 
838                 $node->del();
839         }
840
841         # remove outstanding pings
842         delete $pings{$call};
843         
844         # now broadcast to all other ak1a nodes that I have gone
845         broadcast_ak1a(pc21($call, 'Gone.'), $self) unless $self->{isolate};
846
847         # send info to all logged in thingies
848         $self->tell_login('logoutn');
849
850         Log('DXProt', $call . " Disconnected");
851         $ref->del() if $ref;
852 }
853
854 #
855 # some active measures
856 #
857 sub send_dx_spot
858 {
859         my $self = shift;
860         my $line = shift;
861         my @dxchan = DXChannel->get_all();
862         my $dxchan;
863         
864         # send it if it isn't the except list and isn't isolated and still has a hop count
865         # taking into account filtering and so on
866         foreach $dxchan (@dxchan) {
867                 my $routeit;
868                 my ($filter, $hops);
869
870                 if ($dxchan->{spotfilter}) {
871                     ($filter, $hops) = Filter::it($dxchan->{spotfilter}, @_, $self->{call} );
872                         next unless $filter;
873                 }
874                 
875                 if ($dxchan->is_ak1a) {
876                         next if $dxchan == $self;
877                         if ($hops) {
878                                 $routeit = $line;
879                                 $routeit =~ s/\^H\d+\^\~$/\^H$hops\^\~/;
880                         } else {
881                                 $routeit = adjust_hops($dxchan, $line);  # adjust its hop count by node name
882                                 next unless $routeit;
883                         }
884                         if ($filter) {
885                                 $dxchan->send($routeit) if $routeit;
886                         } else {
887                                 $dxchan->send($routeit) unless $dxchan->{isolate} || $self->{isolate};
888                         }
889                 } elsif ($dxchan->is_user && $dxchan->{dx}) {
890                         my $buf = Spot::formatb($_[0], $_[1], $_[2], $_[3], $_[4]);
891                         $buf .= "\a\a" if $dxchan->{beep};
892                         if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') {
893                                 $dxchan->send($buf);
894                         } else {
895                                 $dxchan->delay($buf);
896                         }
897                 }                                       
898         }
899 }
900
901 sub send_wwv_spot
902 {
903         my $self = shift;
904         my $line = shift;
905         my @dxchan = DXChannel->get_all();
906         my $dxchan;
907         
908         # send it if it isn't the except list and isn't isolated and still has a hop count
909         # taking into account filtering and so on
910         foreach $dxchan (@dxchan) {
911                 my $routeit;
912                 my ($filter, $hops);
913
914                 if ($dxchan->{spotfilter}) {
915                          ($filter, $hops) = Filter::it($dxchan->{wwvfilter}, @_, $self->{call} );
916                          next unless $filter;
917                 }
918                 if ($dxchan->is_ak1a) {
919                         next if $dxchan == $self;
920                         if ($hops) {
921                                 $routeit = $line;
922                                 $routeit =~ s/\^H\d+\^\~$/\^H$hops\^\~/;
923                         } else {
924                                 $routeit = adjust_hops($dxchan, $line);  # adjust its hop count by node name
925                                 next unless $routeit;
926                         }
927                         if ($filter) {
928                                 $dxchan->send($routeit) if $routeit;
929                         } else {
930                                 $dxchan->send($routeit) unless $dxchan->{isolate} || $self->{isolate};
931                                 
932                         }
933                 } elsif ($dxchan->is_user && $dxchan->{wwv}) {
934                         my $buf = "WWV de $_[6] <$_[1]>:   SFI=$_[2], A=$_[3], K=$_[4], $_[5]";
935                         $buf .= "\a\a" if $dxchan->{beep};
936                         if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') {
937                                 $dxchan->send($buf);
938                         } else {
939                                 $dxchan->delay($buf);
940                         }
941                 }                                       
942         }
943 }
944
945 # send an announce
946 sub send_announce
947 {
948         my $self = shift;
949         my $line = shift;
950         my @dxchan = DXChannel->get_all();
951         my $dxchan;
952         my $text = unpad($_[2]);
953         my $target;
954         my $to = 'To ';
955                                 
956         if ($_[3] eq '*') {     # sysops
957                 $target = "SYSOP";
958         } elsif ($_[3] gt ' ') { # speciality list handling
959                 my ($name) = split /\./, $_[3]; 
960                 $target = "$name"; # put the rest in later (if bothered) 
961         } 
962         
963         if ($_[5] eq '1') {
964                 $target = "WX"; 
965                 $to = '';
966         }
967         $target = "All" if !$target;
968         
969         Log('ann', $target, $_[0], $text);
970
971         # send it if it isn't the except list and isn't isolated and still has a hop count
972         # taking into account filtering and so on
973         foreach $dxchan (@dxchan) {
974                 my $routeit;
975                 my ($filter, $hops);
976
977                 if ($dxchan->{annfilter}) {
978                         ($filter, $hops) = Filter::it($dxchan->{annfilter}, @_, $self->{call} );
979                         next unless $filter;
980                 } 
981                 if ($dxchan->is_ak1a && $_[1] ne $main::mycall) {  # i.e not specifically routed to me
982                         next if $dxchan == $self;
983                         if ($hops) {
984                                 $routeit = $line;
985                                 $routeit =~ s/\^H\d+\^\~$/\^H$hops\^\~/;
986                         } else {
987                                 $routeit = adjust_hops($dxchan, $line);  # adjust its hop count by node name
988                                 next unless $routeit;
989                         }
990                         if ($filter) {
991                                 $dxchan->send($routeit) if $routeit;
992                         } else {
993                                 $dxchan->send($routeit) unless $dxchan->{isolate} || $self->{isolate};
994                                 
995                         }
996                 } elsif ($dxchan->is_user && $dxchan->{ann}) {
997                         next if $target eq 'SYSOP' && $dxchan->{priv} < 5;
998                         my $buf = "$to$target de $_[0]: $text";
999                         $buf .= "\a\a" if $dxchan->{beep};
1000                         if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') {
1001                                 $dxchan->send($buf);
1002                         } else {
1003                                 $dxchan->delay($buf);
1004                         }
1005                 }                                       
1006         }
1007 }
1008
1009 sub send_local_config
1010 {
1011         my $self = shift;
1012         my $n;
1013         my @nodes;
1014         my @localnodes;
1015         my @remotenodes;
1016                 
1017         # send our nodes
1018         if ($self->{isolate}) {
1019                 @localnodes = (DXCluster->get_exact($main::mycall));
1020         } else {
1021                 # create a list of all the nodes that are not connected to this connection
1022                 # and are not themselves isolated, this to make sure that isolated nodes
1023         # don't appear outside of this node
1024                 @nodes = DXNode::get_all();
1025                 @nodes = grep { $_->{call} ne $main::mycall } @nodes;
1026                 @nodes = grep { $_->dxchan != $self } @nodes if @nodes;
1027                 @nodes = grep { !$_->dxchan->{isolate} } @nodes if @nodes;
1028                 @localnodes = grep { $_->dxchan->{call} eq $_->{call} } @nodes if @nodes;
1029                 unshift @localnodes, DXCluster->get_exact($main::mycall);
1030                 @remotenodes = grep { $_->dxchan->{call} ne $_->{call} } @nodes if @nodes;
1031         }
1032
1033         my @s = $me->pc19(@localnodes, @remotenodes);
1034         for (@s) {
1035                 my $routeit = adjust_hops($self, $_);
1036                 $self->send($routeit) if $routeit;
1037         }
1038         
1039         # get all the users connected on the above nodes and send them out
1040         foreach $n (@localnodes, @remotenodes) {
1041                 my @users = values %{$n->list};
1042                 my @s = pc16($n, @users);
1043                 for (@s) {
1044                         my $routeit = adjust_hops($self, $_);
1045                         $self->send($routeit) if $routeit;
1046                 }
1047         }
1048 }
1049
1050 #
1051 # route a message down an appropriate interface for a callsign
1052 #
1053 # is called route(to, pcline);
1054 #
1055 sub route
1056 {
1057         my ($self, $call, $line) = @_;
1058         my $cl = DXCluster->get_exact($call);
1059         if ($cl) {       # don't route it back down itself
1060                 if (ref $self && $call eq $self->{call}) {
1061                         dbg('chan', "Trying to route back to source, dropped");
1062                         return;
1063                 }
1064                 my $hops;
1065                 my $dxchan = $cl->{dxchan};
1066                 if ($dxchan) {
1067                         my $routeit = adjust_hops($dxchan, $line);   # adjust its hop count by node name
1068                         if ($routeit) {
1069                                 $dxchan->send($routeit) if $dxchan;
1070                         }
1071                 }
1072         }
1073 }
1074
1075 # broadcast a message to all clusters taking into account isolation
1076 # [except those mentioned after buffer]
1077 sub broadcast_ak1a
1078 {
1079         my $s = shift;                          # the line to be rebroadcast
1080         my @except = @_;                        # to all channels EXCEPT these (dxchannel refs)
1081         my @dxchan = DXChannel::get_all_ak1a();
1082         my $dxchan;
1083         
1084         # send it if it isn't the except list and isn't isolated and still has a hop count
1085         foreach $dxchan (@dxchan) {
1086                 next if grep $dxchan == $_, @except;
1087                 my $routeit = adjust_hops($dxchan, $s);      # adjust its hop count by node name
1088                 $dxchan->send($routeit) unless $dxchan->{isolate} || !$routeit;
1089         }
1090 }
1091
1092 # broadcast a message to all clusters ignoring isolation
1093 # [except those mentioned after buffer]
1094 sub broadcast_all_ak1a
1095 {
1096         my $s = shift;                          # the line to be rebroadcast
1097         my @except = @_;                        # to all channels EXCEPT these (dxchannel refs)
1098         my @dxchan = DXChannel::get_all_ak1a();
1099         my $dxchan;
1100         
1101         # send it if it isn't the except list and isn't isolated and still has a hop count
1102         foreach $dxchan (@dxchan) {
1103                 next if grep $dxchan == $_, @except;
1104                 my $routeit = adjust_hops($dxchan, $s);      # adjust its hop count by node name
1105                 $dxchan->send($routeit);
1106         }
1107 }
1108
1109 # broadcast to all users
1110 # storing the spot or whatever until it is in a state to receive it
1111 sub broadcast_users
1112 {
1113         my $s = shift;                          # the line to be rebroadcast
1114         my $sort = shift;           # the type of transmission
1115         my $fref = shift;           # a reference to an object to filter on
1116         my @except = @_;                        # to all channels EXCEPT these (dxchannel refs)
1117         my @dxchan = DXChannel::get_all_users();
1118         my $dxchan;
1119         my @out;
1120         
1121         foreach $dxchan (@dxchan) {
1122                 next if grep $dxchan == $_, @except;
1123                 push @out, $dxchan;
1124         }
1125         broadcast_list($s, $sort, $fref, @out);
1126 }
1127
1128 # broadcast to a list of users
1129 sub broadcast_list
1130 {
1131         my $s = shift;
1132         my $sort = shift;
1133         my $fref = shift;
1134         my $dxchan;
1135         
1136         foreach $dxchan (@_) {
1137                 my $filter = 1;
1138                 
1139                 if ($sort eq 'dx') {
1140                     next unless $dxchan->{dx};
1141                         ($filter) = Filter::it($dxchan->{spotfilter}, @{$fref}) if ref $fref;
1142                         next unless $filter;
1143                 }
1144                 next if $sort eq 'ann' && !$dxchan->{ann};
1145                 next if $sort eq 'wwv' && !$dxchan->{wwv};
1146                 next if $sort eq 'wx' && !$dxchan->{wx};
1147
1148                 $s =~ s/\a//og unless $dxchan->{beep};
1149
1150                 if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') {
1151                         $dxchan->send($s);      
1152                 } else {
1153                         $dxchan->delay($s);
1154                 }
1155         }
1156 }
1157
1158
1159 #
1160 # obtain the hops from the list for this callsign and pc no 
1161 #
1162
1163 sub get_hops
1164 {
1165         my $pcno = shift;
1166         my $hops = $DXProt::hopcount{$pcno};
1167         $hops = $DXProt::def_hopcount if !$hops;
1168         return "H$hops";       
1169 }
1170
1171
1172 # adjust the hop count on a per node basis using the user loadable 
1173 # hop table if available or else decrement an existing one
1174 #
1175
1176 sub adjust_hops
1177 {
1178         my $self = shift;
1179         my $s = shift;
1180         my $call = $self->{call};
1181         my $hops;
1182         
1183         if (($hops) = $s =~ /\^H(\d+)\^~?$/o) {
1184                 my ($pcno) = $s =~ /^PC(\d\d)/o;
1185                 confess "$call called adjust_hops with '$s'" unless $pcno;
1186                 my $ref = $nodehops{$call} if %nodehops;
1187                 if ($ref) {
1188                         my $newhops = $ref->{$pcno};
1189                         return "" if defined $newhops && $newhops == 0;
1190                         $newhops = $ref->{default} unless $newhops;
1191                         return "" if defined $newhops && $newhops == 0;
1192                         $newhops = $hops if !$newhops;
1193                         $s =~ s/\^H(\d+)(\^~?)$/\^H$newhops$2/ if $newhops;
1194                 } else {
1195                         # simply decrement it
1196                         $hops--;
1197                         return "" if !$hops;
1198                         $s =~ s/\^H(\d+)(\^~?)$/\^H$hops$2/ if $hops;
1199                 }
1200         }
1201         return $s;
1202 }
1203
1204
1205 # load hop tables
1206 #
1207 sub load_hops
1208 {
1209         my $self = shift;
1210         return $self->msg('lh1') unless -e "$main::data/hop_table.pl";
1211         do "$main::data/hop_table.pl";
1212         return $@ if $@;
1213         return 0;
1214 }
1215
1216 # remove leading and trailing spaces from an input string
1217 sub unpad
1218 {
1219         my $s = shift;
1220         $s =~ s/^\s+|\s+$//;
1221         return $s;
1222 }
1223
1224 # add a ping request to the ping queues
1225 sub addping
1226 {
1227         my ($from, $to) = @_;
1228         my $ref = $pings{$to} || [];
1229         my $r = {};
1230         $r->{call} = $from;
1231         $r->{t} = [ gettimeofday ];
1232         route(undef, $to, pc51($to, $main::mycall, 1));
1233         push @$ref, $r;
1234         $pings{$to} = $ref;
1235 }
1236
1237 # add a rcmd request to the rcmd queues
1238 sub addrcmd
1239 {
1240         my ($from, $to, $cmd) = @_;
1241         my $r = {};
1242         $r->{call} = $from;
1243         $r->{t} = $main::systime;
1244         $r->{cmd} = $cmd;
1245         route(undef, $to, pc34($main::mycall, $to, $cmd));
1246         $rcmds{$to} = $r;
1247 }
1248 1;
1249 __END__