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