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