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