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 DXProtVars;
  19 use DXCommandmode;
  20 use DXLog;
  21 use Spot;
  22 use DXProtout;
  23 use DXDebug;
  24 use Filter;
  25 use Local;
  26 use DXDb;
  27 use AnnTalk;
  28 use Geomag;
  29 use WCY;
  30 use Time::HiRes qw(gettimeofday tv_interval);
  31 use BadWords;
  32 use DXHash;
  33 use Route;
  34 use Route::Node;
  35 use Script;
  36 use Investigate;
  37
  38 use strict;
  39
  40 use vars qw($VERSION $BRANCH);
  41 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  42 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  43 $main::build += $VERSION;
  44 $main::branch += $BRANCH;
  45
  46 use vars qw($pc11_max_age $pc23_max_age $last_pc50 $eph_restime $eph_info_restime $eph_pc34_restime
  47                         $last_hour $last10 %eph  %pings %rcmds $ann_to_talk
  48                         $pingint $obscount %pc19list $chatdupeage $investigation_int
  49                         %nodehops $baddx $badspotter $badnode $censorpc $rspfcheck
  50                         $allowzero $decode_dk0wcy $send_opernam @checklist);
  51
  52 $pc11_max_age = 1*3600;                 # the maximum age for an incoming 'real-time' pc11
  53 $pc23_max_age = 1*3600;                 # the maximum age for an incoming 'real-time' pc23
  54
  55 $last_hour = time;                              # last time I did an hourly periodic update
  56 %pings = ();                    # outstanding ping requests outbound
  57 %rcmds = ();                    # outstanding rcmd requests outbound
  58 %nodehops = ();                 # node specific hop control
  59 %pc19list = ();                                 # list of outstanding PC19s that haven't had PC16s on them
  60
  61 $censorpc = 1;                                  # Do a BadWords::check on text fields and reject things
  62                                                                 # loads of 'bad things'
  63 $baddx = new DXHash "baddx";
  64 $badspotter = new DXHash "badspotter";
  65 $badnode = new DXHash "badnode";
  66 $last10 = $last_pc50 = time;
  67 $ann_to_talk = 1;
  68 $rspfcheck = 1;
  69 $eph_restime = 180;
  70 $eph_info_restime = 60*60;
  71 $eph_pc34_restime = 30;
  72 $pingint = 5*60;
  73 $obscount = 2;
  74 $chatdupeage = 20 * 60 * 60;
  75 $investigation_int = 7*86400;   # time between checks to see if we can see this node
  76
  77 @checklist =
  78 (
  79  [ qw(i c c m bp bc c) ],                       # pc10
  80  [ qw(i f m d t m c c h) ],             # pc11
  81  [ qw(i c bm m bm bm p h) ],            # pc12
  82  [ qw(i c h) ],                                 #
  83  [ qw(i c h) ],                                 #
  84  [ qw(i c m h) ],                                       #
  85  undef ,                                                # pc16 has to be validated manually
  86  [ qw(i c c h) ],                                       # pc17
  87  [ qw(i m n) ],                                 # pc18
  88  undef ,                                                # pc19 has to be validated manually
  89  undef ,                                                # pc20 no validation
  90  [ qw(i c m h) ],                                       # pc21
  91  undef ,                                                # pc22 no validation
  92  [ qw(i d n n n n m c c h) ],           # pc23
  93  [ qw(i c p h) ],                                       # pc24
  94  [ qw(i c c n n) ],                             # pc25
  95  [ qw(i f m d t m c c bc) ],            # pc26
  96  [ qw(i d n n n n m c c bc) ],  # pc27
  97  [ qw(i c c m c d t p m bp n p bp bc) ], # pc28
  98  [ qw(i c c n m) ],                             # pc29
  99  [ qw(i c c n) ],                                       # pc30
 100  [ qw(i c c n) ],                                       # pc31
 101  [ qw(i c c n) ],                                       # pc32
 102  [ qw(i c c n) ],                                       # pc33
 103  [ qw(i c c m) ],                                       # pc34
 104  [ qw(i c c m) ],                                       # pc35
 105  [ qw(i c c m) ],                                       # pc36
 106  [ qw(i c c n m) ],                             # pc37
 107  undef,                                                 # pc38 not interested
 108  [ qw(i c m) ],                                 # pc39
 109  [ qw(i c c m p n) ],                           # pc40
 110  [ qw(i c n m h) ],                             # pc41
 111  [ qw(i c c n) ],                                       # pc42
 112  undef,                                                 # pc43 don't handle it
 113  [ qw(i c c n m m c) ],                 # pc44
 114  [ qw(i c c n m) ],                             # pc45
 115  [ qw(i c c n) ],                                       # pc46
 116  undef,                                                 # pc47
 117  undef,                                                 # pc48
 118  [ qw(i c m h) ],                                       # pc49
 119  [ qw(i c n h) ],                                       # pc50
 120  [ qw(i c c n) ],                                       # pc51
 121  undef,
 122  undef,
 123  undef,
 124  undef,
 125  undef,
 126  undef,
 127  undef,
 128  undef,
 129  undef,                                                 # pc60
 130  undef,
 131  undef,
 132  undef,
 133  undef,
 134  undef,
 135  undef,
 136  undef,
 137  undef,
 138  undef,
 139  undef,                                                 # pc70
 140  undef,
 141  undef,
 142  [ qw(i d n n n n n n m m m c c h) ],   # pc73
 143  undef,
 144  undef,
 145  undef,
 146  undef,
 147  undef,
 148  undef,
 149  undef,                                                 # pc80
 150  undef,
 151  undef,
 152  undef,
 153  [ qw(i c c c m) ],                             # pc84
 154  [ qw(i c c c m) ],                             # pc85
 155  undef,
 156  undef,
 157  undef,
 158  undef,
 159  [ qw(i c n) ],                                 # pc90
 160 );
 161
 162 # use the entry in the check list to check the field list presented
 163 # return OK if line NOT in check list (for now)
 164 sub check
 165 {
 166         my $n = shift;
 167         $n -= 10;
 168         return 0 if $n < 0 || $n > @checklist;
 169         my $ref = $checklist[$n];
 170         return 0 unless ref $ref;
 171
 172         my $i;
 173         for ($i = 1; $i < @$ref; $i++) {
 174                 my ($blank, $act) = $$ref[$i] =~ /^(b?)(\w)$/;
 175                 return 0 unless $act;
 176                 next if $blank && $_[$i] =~ /^[ \*]$/;
 177                 if ($act eq 'c') {
 178                         return $i unless is_callsign($_[$i]);
 179                 } elsif ($act eq 'i') {
 180                         ;                                       # do nothing
 181                 } elsif ($act eq 'm') {
 182                         return $i unless is_pctext($_[$i]);
 183                 } elsif ($act eq 'p') {
 184                         return $i unless is_pcflag($_[$i]);
 185                 } elsif ($act eq 'f') {
 186                         return $i unless is_freq($_[$i]);
 187                 } elsif ($act eq 'n') {
 188                         return $i unless $_[$i] =~ /^[\d ]+$/;
 189                 } elsif ($act eq 'h') {
 190                         return $i unless $_[$i] =~ /^H\d\d?$/;
 191                 } elsif ($act eq 'd') {
 192                         return $i unless $_[$i] =~ /^\s*\d+-\w\w\w-[12][90]\d\d$/;
 193                 } elsif ($act eq 't') {
 194                         return $i unless $_[$i] =~ /^[012]\d[012345]\dZ$/;
 195                 }
 196         }
 197         return 0;
 198 }
 199
 200 sub init
 201 {
 202         do "$main::data/hop_table.pl" if -e "$main::data/hop_table.pl";
 203         confess $@ if $@;
 204
 205         my $user = DXUser->get($main::mycall);
 206         $DXProt::myprot_version += $main::version*100;
 207         $main::me = DXProt->SUPER::alloc($main::mycall, 0, $user);
 208         $main::me->{here} = 1;
 209         $main::me->{state} = "indifferent";
 210         $main::me->{sort} = 'S';    # S for spider
 211         $main::me->{priv} = 9;
 212         $main::me->{metric} = 0;
 213         $main::me->{pingave} = 0;
 214         $main::me->{registered} = 1;
 215         $main::me->{version} = $main::version;
 216         $main::me->{build} = $main::build;
 217 }
 218
 219 #
 220 # obtain a new connection this is derived from dxchannel
 221 #
 222
 223 sub new
 224 {
 225         my $self = DXChannel::alloc(@_);
 226
 227         # add this node to the table, the values get filled in later
 228         my $pkg = shift;
 229         my $call = shift;
 230
 231         my $uref = Route::Node::get($call) || Route::Node->new($call);
 232         $uref->here(1);
 233         $uref->conf(0);
 234         $uref->version(5000);
 235         $main::routeroot->link_node($uref, $self);
 236         return $self;
 237 }
 238
 239 # this is how a pc connection starts (for an incoming connection)
 240 # issue a PC38 followed by a PC18, then wait for a PC20 (remembering
 241 # all the crap that comes between).
 242 sub start
 243 {
 244         my ($self, $line, $sort) = @_;
 245         my $call = $self->{call};
 246         my $user = $self->{user};
 247
 248         # log it
 249         my $host = $self->{conn}->{peerhost} || "unknown";
 250         Log('DXProt', "$call connected from $host");
 251
 252         # remember type of connection
 253         $self->{consort} = $line;
 254         $self->{outbound} = $sort eq 'O';
 255         my $priv = $user->priv;
 256         $priv = $user->priv(1) unless $priv;
 257         $self->{priv} = $priv;     # other clusters can always be 'normal' users
 258         $self->{lang} = $user->lang || 'en';
 259         $self->{isolate} = $user->{isolate};
 260         $self->{consort} = $line;       # save the connection type
 261         $self->{here} = 1;
 262         $self->{width} = 80;
 263
 264         # sort out registration
 265         $self->{registered} = 1;
 266
 267         # get the output filters
 268         $self->{spotsfilter} = Filter::read_in('spots', $call, 0) || Filter::read_in('spots', 'node_default', 0);
 269         $self->{wwvfilter} = Filter::read_in('wwv', $call, 0) || Filter::read_in('wwv', 'node_default', 0);
 270         $self->{wcyfilter} = Filter::read_in('wcy', $call, 0) || Filter::read_in('wcy', 'node_default', 0);
 271         $self->{annfilter} = Filter::read_in('ann', $call, 0) || Filter::read_in('ann', 'node_default', 0) ;
 272         $self->{routefilter} = Filter::read_in('route', $call, 0) || Filter::read_in('route', 'node_default', 0) unless $self->{isolate} ;
 273
 274
 275         # get the INPUT filters (these only pertain to Clusters)
 276         $self->{inspotsfilter} = Filter::read_in('spots', $call, 1) || Filter::read_in('spots', 'node_default', 1);
 277         $self->{inwwvfilter} = Filter::read_in('wwv', $call, 1) || Filter::read_in('wwv', 'node_default', 1);
 278         $self->{inwcyfilter} = Filter::read_in('wcy', $call, 1) || Filter::read_in('wcy', 'node_default', 1);
 279         $self->{inannfilter} = Filter::read_in('ann', $call, 1) || Filter::read_in('ann', 'node_default', 1);
 280         $self->{inroutefilter} = Filter::read_in('route', $call, 1) || Filter::read_in('route', 'node_default', 1) unless $self->{isolate};
 281
 282         # set unbuffered and no echo
 283         $self->send_now('B',"0");
 284         $self->send_now('E',"0");
 285         $self->conn->echo(0) if $self->conn->can('echo');
 286
 287         # ping neighbour node stuff
 288         my $ping = $user->pingint;
 289         $ping = $pingint unless defined $ping;
 290         $self->{pingint} = $ping;
 291         $self->{nopings} = $user->nopings || $obscount;
 292         $self->{pingtime} = [ ];
 293         $self->{pingave} = 999;
 294         $self->{metric} ||= 100;
 295         $self->{lastping} = $main::systime;
 296
 297         # send initialisation string
 298         unless ($self->{outbound}) {
 299                 $self->sendinit;
 300         }
 301
 302         $self->state('init');
 303         $self->{pc50_t} = $main::systime;
 304
 305         # send info to all logged in thingies
 306         $self->tell_login('loginn');
 307
 308         # run a script send the output to the debug file
 309         my $script = new Script(lc $call) || new Script('node_default');
 310         $script->run($self) if $script;
 311 }
 312
 313 #
 314 # send outgoing 'challenge'
 315 #
 316
 317 sub sendinit
 318 {
 319         my $self = shift;
 320         $self->send(pc18());
 321 }
 322
 323 sub removepc90
 324 {
 325         $_[0] =~ s/^PC90\^[-A-Z0-9]+\^\d+\^//;
 326         $_[0] =~ s/^PC91\^[-A-Z0-9]+\^\d+\^[-A-Z0-9]+\^//;
 327 }
 328
 329 #sub send
 330 #{
 331 #       my $self = shift;
 332 #       while (@_) {
 333 #               my $line = shift;
 334 #               $self->SUPER::send($line);
 335 #       }
 336 #}
 337
 338 #
 339 # This is the normal pcxx despatcher
 340 #
 341 sub normal
 342 {
 343         my ($self, $line) = @_;
 344
 345         # remove any incoming PC90 frames
 346         removepc90($line);
 347
 348         my @field = split /\^/, $line;
 349         return unless @field;
 350
 351         pop @field if $field[-1] eq '~';
 352
 353 #       print join(',', @field), "\n";
 354
 355
 356         # process PC frames, this will fail unless the frame starts PCnn
 357         my ($pcno) = $field[0] =~ /^PC(\d\d)/; # just get the number
 358         unless (defined $pcno && $pcno >= 10 && $pcno <= 99) {
 359                 dbg("PCPROT: unknown protocol") if isdbg('chanerr');
 360                 return;
 361         }
 362
 363         # check for and dump bad protocol messages
 364         my $n = check($pcno, @field);
 365         if ($n) {
 366                 dbg("PCPROT: bad field $n, dumped (" . parray($checklist[$pcno-10]) . ")") if isdbg('chanerr');
 367                 return;
 368         }
 369
 370         my $origin = $self->{call};
 371         no strict 'subs';
 372         my $sub = "handle_$pcno";
 373
 374         if ($self->can($sub)) {
 375                 $self->$sub($pcno, $line, $origin, @field);
 376         } else {
 377                 $self->handle_default($pcno, $line, $origin, @field);
 378         }
 379 }
 380
 381 # incoming talk commands
 382 sub handle_10
 383 {
 384         my $self = shift;
 385         my $pcno = shift;
 386         my $line = shift;
 387         my $origin = shift;
 388
 389         # rsfp check
 390         return if $rspfcheck and !$self->rspfcheck(0, $_[6], $_[1]);
 391
 392         # will we allow it at all?
 393         if ($censorpc) {
 394                 my @bad;
 395                 if (@bad = BadWords::check($_[3])) {
 396                         dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chanerr');
 397                         return;
 398                 }
 399         }
 400
 401         # is it for me or one of mine?
 402         my ($from, $to, $via, $call, $dxchan);
 403         $from = $_[1];
 404         if ($_[5] gt ' ') {
 405                 $via = $_[2];
 406                 $to = $_[5];
 407         } else {
 408                 $to = $_[2];
 409         }
 410
 411         # if this is a 'nodx' node then ignore it
 412         if ($badnode->in($_[6]) || ($via && $badnode->in($via))) {
 413                 dbg("PCPROT: Bad Node, dropped") if isdbg('chanerr');
 414                 return;
 415         }
 416
 417         # if this is a 'bad spotter' user then ignore it
 418         my $nossid = $from;
 419         $nossid =~ s/-\d+$//;
 420         if ($badspotter->in($nossid)) {
 421                 dbg("PCPROT: Bad Spotter, dropped") if isdbg('chanerr');
 422                 return;
 423         }
 424
 425         # if we are converting announces to talk is it a dup?
 426         if ($ann_to_talk) {
 427                 if (AnnTalk::is_talk_candidate($from, $_[3]) && AnnTalk::dup($from, $to, $_[3])) {
 428                         dbg("DXPROT: Dupe talk from announce, dropped") if isdbg('chanerr');
 429                         return;
 430                 }
 431         }
 432
 433         # it is here and logged on
 434         $dxchan = DXChannel->get($main::myalias) if $to eq $main::mycall;
 435         $dxchan = DXChannel->get($to) unless $dxchan;
 436         if ($dxchan && $dxchan->is_user) {
 437                 $_[3] =~ s/\%5E/^/g;
 438                 $dxchan->talk($from, $to, $via, $_[3]);
 439                 return;
 440         }
 441
 442         # is it elsewhere, visible on the cluster via the to address?
 443         # note: this discards the via unless the to address is on
 444         # the via address
 445         my ($ref, $vref);
 446         if ($ref = Route::get($to)) {
 447                 $vref = Route::Node::get($via) if $via;
 448                 $vref = undef unless $vref && grep $to eq $_, $vref->users;
 449                 $ref->bestdxchan->talk($from, $to, $vref ? $via : undef, $_[3], $_[6]);
 450                 return;
 451         }
 452
 453         # not visible here, send a message of condolence
 454         $vref = undef;
 455         $ref = Route::get($from);
 456         $vref = $ref = Route::Node::get($_[6]) unless $ref;
 457         if ($ref) {
 458                 $dxchan = $ref->bestdxchan;
 459                 $dxchan->talk($main::mycall, $from, $vref ? $vref->call : undef, $dxchan->msg('talknh', $to) );
 460         }
 461 }
 462
 463 # DX Spot handling
 464 sub handle_11
 465 {
 466         my $self = shift;
 467         my $pcno = shift;
 468         my $line = shift;
 469         my $origin = shift;
 470
 471         # route 'foreign' pc26s
 472         if ($pcno == 26) {
 473                 if ($_[7] ne $main::mycall) {
 474                         $self->route($_[7], $line);
 475                         return;
 476                 }
 477         }
 478
 479         # rsfp check
 480         #                       return if $rspfcheck and !$self->rspfcheck(1, $_[7], $_[6]);
 481
 482         # if this is a 'nodx' node then ignore it
 483         if ($badnode->in($_[7])) {
 484                 dbg("PCPROT: Bad Node, dropped") if isdbg('chanerr');
 485                 return;
 486         }
 487
 488         # if this is a 'bad spotter' user then ignore it
 489         my $nossid = $_[6];
 490         $nossid =~ s/-\d+$//;
 491         if ($badspotter->in($nossid)) {
 492                 dbg("PCPROT: Bad Spotter, dropped") if isdbg('chanerr');
 493                 return;
 494         }
 495
 496         # convert the date to a unix date
 497         my $d = cltounix($_[3], $_[4]);
 498         # bang out (and don't pass on) if date is invalid or the spot is too old (or too young)
 499         if (!$d || ($pcno == 11 && ($d < $main::systime - $pc11_max_age || $d > $main::systime + 900))) {
 500                 dbg("PCPROT: Spot ignored, invalid date or out of range ($_[3] $_[4])\n") if isdbg('chanerr');
 501                 return;
 502         }
 503
 504         # is it 'baddx'
 505         if ($baddx->in($_[2]) || BadWords::check($_[2]) || $_[2] =~ /COCK/) {
 506                 dbg("PCPROT: Bad DX spot, ignored") if isdbg('chanerr');
 507                 return;
 508         }
 509
 510         # do some de-duping
 511         $_[5] =~ s/^\s+//;                      # take any leading blanks off
 512         $_[2] = unpad($_[2]);           # take off leading and trailing blanks from spotted callsign
 513         if ($_[2] =~ /BUST\w*$/) {
 514                 dbg("PCPROT: useless 'BUSTED' spot") if isdbg('chanerr');
 515                 return;
 516         }
 517         if ($censorpc) {
 518                 my @bad;
 519                 if (@bad = BadWords::check($_[5])) {
 520                         dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chanerr');
 521                         return;
 522                 }
 523         }
 524
 525
 526         my @spot = Spot::prepare($_[1], $_[2], $d, $_[5], $_[6], $_[7]);
 527         # global spot filtering on INPUT
 528         if ($self->{inspotsfilter}) {
 529                 my ($filter, $hops) = $self->{inspotsfilter}->it(@spot);
 530                 unless ($filter) {
 531                         dbg("PCPROT: Rejected by input spot filter") if isdbg('chanerr');
 532                         return;
 533                 }
 534         }
 535
 536         # this goes after the input filtering, but before the add
 537         # so that if it is input filtered, it isn't added to the dup
 538         # list. This allows it to come in from a "legitimate" source
 539         if (Spot::dup($_[1], $_[2], $d, $_[5], $_[6])) {
 540                 dbg("PCPROT: Duplicate Spot ignored\n") if isdbg('chanerr');
 541                 return;
 542         }
 543
 544         # add it
 545         Spot::add(@spot);
 546
 547         #
 548         # @spot at this point contains:-
 549         # freq, spotted call, time, text, spotter, spotted cc, spotters cc, orig node
 550         # then  spotted itu, spotted cq, spotters itu, spotters cq
 551         # you should be able to route on any of these
 552         #
 553
 554         # fix up qra locators of known users
 555         my $user = DXUser->get_current($spot[4]);
 556         if ($user) {
 557                 my $qra = $user->qra;
 558                 unless ($qra && is_qra($qra)) {
 559                         my $lat = $user->lat;
 560                         my $long = $user->long;
 561                         if (defined $lat && defined $long) {
 562                                 $user->qra(DXBearing::lltoqra($lat, $long));
 563                                 $user->put;
 564                         }
 565                 }
 566
 567                 # send a remote command to a distant cluster if it is visible and there is no
 568                 # qra locator and we havn't done it for a month.
 569
 570                 unless ($user->qra) {
 571                         my $node;
 572                         my $to = $user->homenode;
 573                         my $last = $user->lastoper || 0;
 574                         if ($send_opernam && $to && $to ne $main::mycall && $main::systime > $last + $DXUser::lastoperinterval && ($node = Route::Node::get($to)) ) {
 575                                 my $cmd = "forward/opernam $spot[4]";
 576                                 # send the rcmd but we aren't interested in the replies...
 577                                 my $dxchan = $node->bestdxchan;
 578                                 if ($dxchan && $dxchan->is_clx) {
 579                                         route(undef, $to, pc84($main::mycall, $to, $main::mycall, $cmd));
 580                                 } else {
 581                                         route(undef, $to, pc34($main::mycall, $to, $cmd));
 582                                 }
 583                                 if ($to ne $_[7]) {
 584                                         $to = $_[7];
 585                                         $node = Route::Node::get($to);
 586                                         if ($node) {
 587                                                 $dxchan = $node->bestdxchan;
 588                                                 if ($dxchan && $dxchan->is_clx) {
 589                                                         route(undef, $to, pc84($main::mycall, $to, $main::mycall, $cmd));
 590                                                 } else {
 591                                                         route(undef, $to, pc34($main::mycall, $to, $cmd));
 592                                                 }
 593                                         }
 594                                 }
 595                                 $user->lastoper($main::systime);
 596                                 $user->put;
 597                         }
 598                 }
 599         }
 600
 601         # local processing
 602         my $r;
 603         eval {
 604                 $r = Local::spot($self, @spot);
 605         };
 606         #                       dbg("Local::spot1 error $@") if isdbg('local') if $@;
 607         return if $r;
 608
 609         # DON'T be silly and send on PC26s!
 610         return if $pcno == 26;
 611
 612         # send out the filtered spots
 613         send_dx_spot($self, $line, @spot) if @spot;
 614 }
 615
 616 # announces
 617 sub handle_12
 618 {
 619         my $self = shift;
 620         my $pcno = shift;
 621         my $line = shift;
 622         my $origin = shift;
 623
 624         #                       return if $rspfcheck and !$self->rspfcheck(1, $_[5], $_[1]);
 625
 626         # announce duplicate checking
 627         $_[3] =~ s/^\s+//;                      # remove leading blanks
 628
 629         if ($censorpc) {
 630                 my @bad;
 631                 if (@bad = BadWords::check($_[3])) {
 632                         dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chanerr');
 633                         return;
 634                 }
 635         }
 636
 637         # if this is a 'nodx' node then ignore it
 638         if ($badnode->in($_[5])) {
 639                 dbg("PCPROT: Bad Node, dropped") if isdbg('chanerr');
 640                 return;
 641         }
 642
 643         # if this is a 'bad spotter' user then ignore it
 644         my $nossid = $_[1];
 645         $nossid =~ s/-\d+$//;
 646         if ($badspotter->in($nossid)) {
 647                 dbg("PCPROT: Bad Spotter, dropped") if isdbg('chanerr');
 648                 return;
 649         }
 650
 651         my $dxchan;
 652
 653         if ((($dxchan = DXChannel->get($_[2])) && $dxchan->is_user) || $_[4] =~ /^[\#\w.]+$/){
 654                 $self->send_chat($line, @_[1..6]);
 655         } elsif ($_[2] eq '*' || $_[2] eq $main::mycall) {
 656
 657                 # ignore something that looks like a chat line coming in with sysop
 658                 # flag - this is a kludge...
 659                 if ($_[3] =~ /^\#\d+ / && $_[4] eq '*') {
 660                         dbg('PCPROT: Probable chat rewrite, dropped') if isdbg('chanerr');
 661                         return;
 662                 }
 663
 664                 # here's a bit of fun, convert incoming ann with a callsign in the first word
 665                 # or one saying 'to <call>' to a talk if we can route to the recipient
 666                 if ($ann_to_talk) {
 667                         my $call = AnnTalk::is_talk_candidate($_[1], $_[3]);
 668                         if ($call) {
 669                                 my $ref = Route::get($call);
 670                                 if ($ref) {
 671                                         $dxchan = $ref->bestdxchan;
 672                                         $dxchan->talk($_[1], $call, undef, $_[3], $_[5]) if $dxchan != $self;
 673                                         return;
 674                                 }
 675                         }
 676                 }
 677
 678                 # send it
 679                 $self->send_announce($line, @_[1..6]);
 680         } else {
 681                 $self->route($_[2], $line);
 682         }
 683 }
 684
 685 # incoming user
 686 sub handle_16
 687 {
 688         my $self = shift;
 689         my $pcno = shift;
 690         my $line = shift;
 691         my $origin = shift;
 692
 693
 694         # general checks
 695         my $dxchan;
 696         my $ncall = $_[1];
 697         my $newline = "PC16^";
 698
 699         # do I want users from this channel?
 700         unless ($self->user->wantpc16) {
 701                 dbg("PCPROT: don't send users to $self->{call}") if isdbg('chanerr');
 702                 return;
 703         }
 704
 705         # is it me?
 706         if ($ncall eq $main::mycall) {
 707                 dbg("PCPROT: trying to alter config on this node from outside!") if isdbg('chanerr');
 708                 return;
 709         }
 710
 711         # do we believe this call?
 712         unless ($ncall eq $self->{call} || $self->is_believed($ncall)) {
 713                 dbg("PCPROT: We don't believe $ncall on $self->{call}");
 714                 return;
 715         }
 716
 717         my $node = Route::Node::get($ncall);
 718         unless ($node) {
 719                 dbg("PCPROT: Node $ncall not in config") if isdbg('chanerr');
 720                 return;
 721         }
 722
 723         # dedupe only that which we potentially process
 724         if (eph_dup($line)) {
 725                 dbg("PCPROT: dup PC16 detected") if isdbg('chanerr');
 726                 return;
 727         }
 728
 729         my $i;
 730         my @rout;
 731         my @new;
 732         for ($i = 2; $i < $#_; $i++) {
 733                 my ($call, $conf, $here) = $_[$i] =~ /^(\S+) (\S) (\d)/o;
 734                 next unless $call && $conf && defined $here && is_callsign($call);
 735                 next if $call eq $main::mycall;
 736
 737                 eph_del_regex("^PC17\\^$call\\^$ncall");
 738
 739                 $conf = $conf eq '*';
 740
 741                 # reject this if we think it is a node already
 742                 my $r = Route::Node::get($call);
 743                 my $u = DXUser->get_current($call) unless $r;
 744                 if ($r || ($u && $u->is_node)) {
 745                         dbg("PCPROT: $call is a node") if isdbg('chanerr');
 746                         next;
 747                 }
 748
 749                 $r = Route::User::get($call) || Route::User->new($call);
 750                 $r->here($here);
 751                 $r->conf($conf);
 752                 $node->lastseen($main::systime);
 753
 754                 push @new, $node->add_user($r);
 755
 756                 # add this station to the user database, if required
 757                 $call =~ s/-\d+$//o;    # remove ssid for users
 758                 my $user = DXUser->get_current($call);
 759                 $user = DXUser->new($call) if !$user;
 760                 $user->homenode($node->call) if !$user->homenode;
 761                 $user->node($node->call);
 762                 $user->lastin($main::systime) unless DXChannel->get($call);
 763                 $user->put;
 764         }
 765         $self->route_pc16($origin, $line, $node, @new) if @new;
 766 }
 767
 768 # remove a user
 769 sub handle_17
 770 {
 771         my $self = shift;
 772         my $pcno = shift;
 773         my $line = shift;
 774         my $origin = shift;
 775         my $dxchan;
 776         my $ncall = $_[2];
 777         my $ucall = $_[1];
 778
 779         eph_del_regex("^PC16\\^$ncall.*$ucall");
 780
 781         # do I want users from this channel?
 782         unless ($self->user->wantpc16) {
 783                 dbg("PCPROT: don't send users to $self->{call}") if isdbg('chanerr');
 784                 return;
 785         }
 786         if ($ncall eq $main::mycall) {
 787                 dbg("PCPROT: trying to alter config on this node from outside!") if isdbg('chanerr');
 788                 return;
 789         }
 790
 791         # do we believe this call?
 792         unless ($ncall eq $self->{call} || $self->is_believed($ncall)) {
 793                 dbg("PCPROT: We don't believe $ncall on $self->{call}");
 794                 return;
 795         }
 796
 797         my $uref = Route::User::get($ucall);
 798         unless ($uref) {
 799                 dbg("PCPROT: Route::User $ucall not in config") if isdbg('chanerr');
 800         }
 801         my $node = Route::Node::get($ncall);
 802         unless ($node) {
 803                 dbg("PCPROT: Route::Node $ncall not in config") if isdbg('chanerr');
 804         }
 805
 806         return unless $node && $uref;
 807
 808         my @rout;
 809         my @new;
 810         if ($self->in_filter_route($node)) {
 811
 812                 if (eph_dup($line)) {
 813                         dbg("PCPROT: dup PC17 detected") if isdbg('chanerr');
 814                         return;
 815                 }
 816                 push @new, $node->del_user($uref);
 817         }
 818
 819         $self->route_pc17($origin, $line, $node, $uref) if @new;
 820
 821         # get rid of orphaned users;
 822         $_->delete for @new;
 823 }
 824
 825 # link request
 826 sub handle_18
 827 {
 828         my $self = shift;
 829         my $pcno = shift;
 830         my $line = shift;
 831         my $origin = shift;
 832         $self->state('init');
 833
 834         # record the type and version offered
 835         if ($_[1] =~ /DXSpider Version: (\d+\.\d+) Build: (\d+\.\d+)/) {
 836                 $self->version(53 + $1);
 837                 $self->user->version(53 + $1);
 838                 $self->build(0 + $2);
 839                 $self->user->build(0 + $2);
 840                 unless ($self->is_spider) {
 841                         $self->user->sort('S');
 842                         $self->user->put;
 843                         $self->sort('S');
 844                 }
 845         } else {
 846                 $self->version(50.0);
 847                 $self->version($_[2] / 100) if $_[2] && $_[2] =~ /^\d+$/;
 848                 $self->user->version($self->version);
 849         }
 850         $self->newroute( $_[1] =~ /NewRoute/ );
 851
 852         # first clear out any nodes on this dxchannel
 853         my $node = Route::Node::get($self->{call}) ;
 854         my @rout;
 855         foreach my $n ($node->nodes) {
 856                 next if $n eq $main::mycall;
 857                 next if $n eq $self->{call};
 858                 my $nref = Route::Node::get($n);
 859                 push @rout, $node->remove_route($nref, $self) if $nref;
 860         }
 861         $self->route_pc21($origin, $line, @rout) if @rout;
 862         for (@rout) {
 863                 $_->delete;
 864         };
 865
 866         # send the new config
 867         $self->send_local_config();
 868         $self->send(pc20());
 869 }
 870
 871 # incoming cluster list
 872 sub handle_19
 873 {
 874         my $self = shift;
 875         my $pcno = shift;
 876         my $line = shift;
 877         my $origin = shift;
 878
 879         my $i;
 880         my $newline = "PC19^";
 881
 882         if (eph_dup($line)) {
 883                 dbg("PCPROT: dup PC19 detected") if isdbg('chanerr');
 884                 return;
 885         }
 886
 887         # new routing list
 888         my @rout;
 889
 890         # first get the INTERFACE node
 891         my $parent = Route::Node::get($self->{call});
 892         unless ($parent) {
 893                 dbg("DXPROT: my parent $self->{call} has disappeared");
 894                 $self->disconnect;
 895                 return;
 896         }
 897
 898         my @new;
 899
 900         # parse the PC19
 901         for ($i = 1; $i < $#_-1; $i += 4) {
 902                 my $here = $_[$i];
 903                 my $call = uc $_[$i+1];
 904                 my $conf = $_[$i+2];
 905                 my $ver = $_[$i+3];
 906                 next unless defined $here && defined $conf && is_callsign($call);
 907
 908                 # check for sane parameters
 909                 #                               $ver = 5000 if $ver eq '0000';
 910                 next if $ver < 5000;    # only works with version 5 software
 911                 next if length $call < 3; # min 3 letter callsigns
 912                 next if $call eq $main::mycall;
 913
 914                 # add this station to the user database, if required (don't remove SSID from nodes)
 915                 my $user = DXUser->get_current($call);
 916                 if (!$user) {
 917                         $user = DXUser->new($call);
 918                         $user->sort('A');
 919                         $user->priv(1);         # I have relented and defaulted nodes
 920                         $user->lockout(1);
 921                         $user->homenode($call);
 922                         $user->node($call);
 923                 }
 924                 $user->wantroutepc19(1) unless defined $user->wantroutepc19;
 925                 $user->lastin($main::systime) unless DXChannel->get($call);
 926                 $user->put;
 927
 928                 # do we believe this call?
 929                 unless ($call eq $self->{call} || $self->is_believed($call)) {
 930                         my $pt = $user->lastping || 0;
 931                         if ($pt+$investigation_int < $main::systime && !Investigate::get($call)) {
 932                                 my $iref = Investigate->new($call);
 933                                 $iref->version($ver);
 934                                 $iref->here($here);
 935                         }
 936                         dbg("PCPROT: We don't believe $call on $self->{call}");
 937                         next;
 938                 }
 939
 940                 eph_del_regex("^PC(?:21\\^$call|17\\^[^\\^]+\\^$call)");
 941
 942                 my $r = Route::Node::get($call) || Route::Node->new($call);
 943                 $r->here($here);
 944                 $r->conf($conf);
 945                 $r->version($ver);
 946                 $r->lastseen($main::systime);
 947
 948                 if ($self->in_filter_route($r)) {
 949                         push @new, $parent->link_node($r, $self);
 950                         push @rout, $r;
 951                 }
 952
 953                 # unbusy and stop and outgoing mail (ie if somehow we receive another PC19 without a disconnect)
 954                 my $mref = DXMsg::get_busy($call);
 955                 $mref->stop_msg($call) if $mref;
 956         }
 957
 958         # route out new nodes to legacy nodes
 959         $self->route_pc19($origin, $line, @new) if @new;
 960         $self->route_pc59('A', 0, $self->{call}, @rout) if @rout;
 961 }
 962
 963 # send local configuration
 964 sub handle_20
 965 {
 966         my $self = shift;
 967         my $pcno = shift;
 968         my $line = shift;
 969         my $origin = shift;
 970         $self->send_local_config();
 971         $self->send(pc22());
 972         $self->state('normal');
 973         $self->{lastping} = 0;
 974 }
 975
 976 # delete a cluster from the list
 977 sub handle_21
 978 {
 979         my $self = shift;
 980         my $pcno = shift;
 981         my $line = shift;
 982         my $origin = shift;
 983         my $call = uc $_[1];
 984
 985         return if $call eq $main::mycall;  # don't allow malicious buggers to disconnect me (or ignore loops)!
 986
 987         unless ($call eq $self->{call} || $self->is_believed($call)) {
 988                 dbg("PCPROT: We don't believe $call on $self->{call}");
 989                 return;
 990         }
 991
 992         eph_del_regex("^PC1[679].*$call");
 993
 994         # if I get a PC21 from the same callsign as self then treat it
 995         # as a PC39: I have gone away
 996         if ($call eq $self->call) {
 997                 $self->disconnect(1);
 998                 return;
 999         }
1000
1001         my @rout;
1002         my @new;
1003         my $parent = Route::Node::get($self->{call});
1004         unless ($parent) {
1005                 dbg("DXPROT: my parent $self->{call} has disappeared");
1006                 $self->disconnect;
1007                 return;
1008         }
1009         $parent->lastseen;
1010
1011         my $node = Route::Node::get($call);
1012         if ($node) {
1013                 $node->lastseen($main::systime);
1014
1015                 # input filter it
1016                 return unless $self->in_filter_route($node);
1017                 push @rout, $node;
1018                 push @new, $node->link_node($parent, $self);
1019         }
1020
1021         $self->route_pc21($origin, $line, @new) if @new;
1022         $self->route_pc59('D', 0, $self->{call}, @rout) if @rout;
1023
1024         # get rid of orphaned nodes;
1025         $_->delete for @new;
1026 }
1027
1028
1029 sub handle_22
1030 {
1031         my $self = shift;
1032         my $pcno = shift;
1033         my $line = shift;
1034         my $origin = shift;
1035         $self->state('normal');
1036         $self->{lastping} = 0;
1037 }
1038
1039 # WWV info
1040 sub handle_23
1041 {
1042         my $self = shift;
1043         my $pcno = shift;
1044         my $line = shift;
1045         my $origin = shift;
1046
1047         # route foreign' pc27s
1048         if ($pcno == 27) {
1049                 if ($_[8] ne $main::mycall) {
1050                         $self->route($_[8], $line);
1051                         return;
1052                 }
1053         }
1054
1055         # only do a rspf check on PC23 (not 27)
1056         if ($pcno == 23) {
1057                 return if $rspfcheck and !$self->rspfcheck(1, $_[8], $_[7])
1058         }
1059
1060         # do some de-duping
1061         my $d = cltounix($_[1], sprintf("%02d18Z", $_[2]));
1062         my $sfi = unpad($_[3]);
1063         my $k = unpad($_[4]);
1064         my $i = unpad($_[5]);
1065         my ($r) = $_[6] =~ /R=(\d+)/;
1066         $r = 0 unless $r;
1067         if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $_[2] < 0 || $_[2] > 23) {
1068                 dbg("PCPROT: WWV Date ($_[1] $_[2]) out of range") if isdbg('chanerr');
1069                 return;
1070         }
1071         if (Geomag::dup($d,$sfi,$k,$i,$_[6])) {
1072                 dbg("PCPROT: Dup WWV Spot ignored\n") if isdbg('chanerr');
1073                 return;
1074         }
1075         $_[7] =~ s/-\d+$//o;            # remove spotter's ssid
1076
1077         my $wwv = Geomag::update($d, $_[2], $sfi, $k, $i, @_[6..8], $r);
1078
1079         my $rep;
1080         eval {
1081                 $rep = Local::wwv($self, $_[1], $_[2], $sfi, $k, $i, @_[6..8], $r);
1082         };
1083         #                       dbg("Local::wwv2 error $@") if isdbg('local') if $@;
1084         return if $rep;
1085
1086         # DON'T be silly and send on PC27s!
1087         return if $pcno == 27;
1088
1089         # broadcast to the eager world
1090         send_wwv_spot($self, $line, $d, $_[2], $sfi, $k, $i, @_[6..8]);
1091 }
1092
1093 # set here status
1094 sub handle_24
1095 {
1096         my $self = shift;
1097         my $pcno = shift;
1098         my $line = shift;
1099         my $origin = shift;
1100         my $call = uc $_[1];
1101         my ($nref, $uref);
1102         $nref = Route::Node::get($call);
1103         $uref = Route::User::get($call);
1104         return unless $nref || $uref; # if we don't know where they are, it's pointless sending it on
1105
1106         if (eph_dup($line)) {
1107                 dbg("PCPROT: Dup PC24 ignored\n") if isdbg('chanerr');
1108                 return;
1109         }
1110
1111         $nref->here($_[2]) if $nref;
1112         $uref->here($_[2]) if $uref;
1113         my $ref = $nref || $uref;
1114         return unless $self->in_filter_route($ref);
1115
1116         $self->route_pc24($origin, $line, $ref, $_[3]);
1117 }
1118
1119 # merge request
1120 sub handle_25
1121 {
1122         my $self = shift;
1123         my $pcno = shift;
1124         my $line = shift;
1125         my $origin = shift;
1126         if ($_[1] ne $main::mycall) {
1127                 $self->route($_[1], $line);
1128                 return;
1129         }
1130         if ($_[2] eq $main::mycall) {
1131                 dbg("PCPROT: Trying to merge to myself, ignored") if isdbg('chanerr');
1132                 return;
1133         }
1134
1135         Log('DXProt', "Merge request for $_[3] spots and $_[4] WWV from $_[2]");
1136
1137         # spots
1138         if ($_[3] > 0) {
1139                 my @in = reverse Spot::search(1, undef, undef, 0, $_[3]);
1140                 my $in;
1141                 foreach $in (@in) {
1142                         $self->send(pc26(@{$in}[0..4], $_[2]));
1143                 }
1144         }
1145
1146         # wwv
1147         if ($_[4] > 0) {
1148                 my @in = reverse Geomag::search(0, $_[4], time, 1);
1149                 my $in;
1150                 foreach $in (@in) {
1151                         $self->send(pc27(@{$in}[0..5], $_[2]));
1152                 }
1153         }
1154 }
1155
1156 sub handle_26 {goto &handle_11}
1157 sub handle_27 {goto &handle_23}
1158
1159 # mail/file handling
1160 sub handle_28
1161 {
1162         my $self = shift;
1163         my $pcno = shift;
1164         my $line = shift;
1165         my $origin = shift;
1166         if ($_[1] eq $main::mycall) {
1167                 no strict 'refs';
1168                 my $sub = "DXMsg::handle_$pcno";
1169                 &$sub($self, @_);
1170         } else {
1171                 $self->route($_[1], $line) unless $self->is_clx;
1172         }
1173 }
1174
1175 sub handle_29 {goto &handle_28}
1176 sub handle_30 {goto &handle_28}
1177 sub handle_31 {goto &handle_28}
1178 sub handle_32 {goto &handle_28}
1179 sub handle_33 {goto &handle_28}
1180
1181 sub handle_34
1182 {
1183         my $self = shift;
1184         my $pcno = shift;
1185         my $line = shift;
1186         my $origin = shift;
1187         if (eph_dup($line, $eph_pc34_restime)) {
1188                 dbg("PCPROT: dupe PC34, ignored") if isdbg('chanerr');
1189         } else {
1190                 $self->process_rcmd($_[1], $_[2], $_[2], $_[3]);
1191         }
1192 }
1193
1194 # remote command replies
1195 sub handle_35
1196 {
1197         my $self = shift;
1198         my $pcno = shift;
1199         my $line = shift;
1200         my $origin = shift;
1201         eph_del_regex("^PC35\\^$_[2]\\^$_[1]\\^");
1202         $self->process_rcmd_reply($_[1], $_[2], $_[1], $_[3]);
1203 }
1204
1205 sub handle_36 {goto &handle_34}
1206
1207 # database stuff
1208 sub handle_37
1209 {
1210         my $self = shift;
1211         my $pcno = shift;
1212         my $line = shift;
1213         my $origin = shift;
1214         if ($_[1] eq $main::mycall) {
1215                 no strict 'refs';
1216                 my $sub = "DXDb::handle_$pcno";
1217                 &$sub($self, @_);
1218         } else {
1219                 $self->route($_[1], $line) unless $self->is_clx;
1220         }
1221 }
1222
1223 # node connected list from neighbour
1224 sub handle_38
1225 {
1226         my $self = shift;
1227         my $pcno = shift;
1228         my $line = shift;
1229         my $origin = shift;
1230 }
1231
1232 # incoming disconnect
1233 sub handle_39
1234 {
1235         my $self = shift;
1236         my $pcno = shift;
1237         my $line = shift;
1238         my $origin = shift;
1239         if ($_[1] eq $self->{call}) {
1240                 $self->disconnect(1);
1241         } else {
1242                 dbg("PCPROT: came in on wrong channel") if isdbg('chanerr');
1243         }
1244 }
1245
1246 sub handle_40 {goto &handle_28}
1247
1248 # user info
1249 sub handle_41
1250 {
1251         my $self = shift;
1252         my $pcno = shift;
1253         my $line = shift;
1254         my $origin = shift;
1255         my $call = $_[1];
1256
1257         my $l = $line;
1258         $l =~ s/[\x00-\x20\x7f-\xff]+//g; # remove all funny characters and spaces for dup checking
1259         if (eph_dup($l, $eph_info_restime)) {
1260                 dbg("PCPROT: dup PC41, ignored") if isdbg('chanerr');
1261                 return;
1262         }
1263
1264         # input filter if required
1265         #                       my $ref = Route::get($call) || Route->new($call);
1266         #                       return unless $self->in_filter_route($ref);
1267
1268         if ($_[3] eq $_[2] || $_[3] =~ /^\s*$/) {
1269                 dbg('PCPROT: invalid value') if isdbg('chanerr');
1270                 return;
1271         }
1272
1273         # add this station to the user database, if required
1274         my $user = DXUser->get_current($call);
1275         $user = DXUser->new($call) unless $user;
1276
1277         if ($_[2] == 1) {
1278                 $user->name($_[3]);
1279         } elsif ($_[2] == 2) {
1280                 $user->qth($_[3]);
1281         } elsif ($_[2] == 3) {
1282                 if (is_latlong($_[3])) {
1283                         my ($lat, $long) = DXBearing::stoll($_[3]);
1284                         $user->lat($lat);
1285                         $user->long($long);
1286                         $user->qra(DXBearing::lltoqra($lat, $long));
1287                 } else {
1288                         dbg('PCPROT: not a valid lat/long') if isdbg('chanerr');
1289                         return;
1290                 }
1291         } elsif ($_[2] == 4) {
1292                 $user->homenode($_[3]);
1293         } elsif ($_[2] == 5) {
1294                 if (is_qra(uc $_[3])) {
1295                         my ($lat, $long) = DXBearing::qratoll(uc $_[3]);
1296                         $user->lat($lat);
1297                         $user->long($long);
1298                         $user->qra(uc $_[3]);
1299                 } else {
1300                         dbg('PCPROT: not a valid QRA locator') if isdbg('chanerr');
1301                         return;
1302                 }
1303         }
1304         $user->lastoper($main::systime); # to cut down on excessive for/opers being generated
1305         $user->put;
1306
1307         unless ($self->{isolate}) {
1308                 DXChannel::broadcast_nodes($line, $self); # send it to everyone but me
1309         }
1310
1311         #  perhaps this IS what we want after all
1312         #                       $self->route_pc41($ref, $call, $_[2], $_[3], $_[4]);
1313 }
1314
1315 sub handle_42 {goto &handle_28}
1316
1317
1318 # database
1319 sub handle_44 {goto &handle_37}
1320 sub handle_45 {goto &handle_37}
1321 sub handle_46 {goto &handle_37}
1322 sub handle_47 {goto &handle_37}
1323 sub handle_48 {goto &handle_37}
1324
1325 # message and database
1326 sub handle_49
1327 {
1328         my $self = shift;
1329         my $pcno = shift;
1330         my $line = shift;
1331         my $origin = shift;
1332
1333         if (eph_dup($line)) {
1334                 dbg("PCPROT: Dup PC49 ignored\n") if isdbg('chanerr');
1335                 return;
1336         }
1337
1338         if ($_[1] eq $main::mycall) {
1339                 DXMsg::handle_49($self, @_);
1340         } else {
1341                 $self->route($_[1], $line) unless $self->is_clx;
1342         }
1343 }
1344
1345 # keep alive/user list
1346 sub handle_50
1347 {
1348         my $self = shift;
1349         my $pcno = shift;
1350         my $line = shift;
1351         my $origin = shift;
1352
1353         my $call = $_[1];
1354         my $node = Route::Node::get($call);
1355         if ($node) {
1356                 return unless $node->call eq $self->{call};
1357                 $node->usercount($_[2]);
1358
1359                 # input filter if required
1360                 return unless $self->in_filter_route($node);
1361
1362                 $self->route_pc50($origin, $line, $node, $_[2], $_[3]) unless eph_dup($line);
1363         }
1364 }
1365
1366 # incoming ping requests/answers
1367 sub handle_51
1368 {
1369         my $self = shift;
1370         my $pcno = shift;
1371         my $line = shift;
1372         my $origin = shift;
1373         my $to = $_[1];
1374         my $from = $_[2];
1375         my $flag = $_[3];
1376
1377
1378         # is it for us?
1379         if ($to eq $main::mycall) {
1380                 if ($flag == 1) {
1381                         $self->send(pc51($from, $to, '0'));
1382                 } else {
1383                         # it's a reply, look in the ping list for this one
1384                         my $ref = $pings{$from};
1385                         if ($ref) {
1386                                 my $tochan =  DXChannel->get($from);
1387                                 while (@$ref) {
1388                                         my $r = shift @$ref;
1389                                         my $dxchan = DXChannel->get($r->{call});
1390                                         next unless $dxchan;
1391                                         my $t = tv_interval($r->{t}, [ gettimeofday ]);
1392                                         if ($dxchan->is_user) {
1393                                                 my $s = sprintf "%.2f", $t;
1394                                                 my $ave = sprintf "%.2f", $tochan ? ($tochan->{pingave} || $t) : $t;
1395                                                 $dxchan->send($dxchan->msg('pingi', $from, $s, $ave))
1396                                         } elsif ($dxchan->is_node) {
1397                                                 if ($tochan) {
1398                                                         my $nopings = $tochan->user->nopings || $obscount;
1399                                                         push @{$tochan->{pingtime}}, $t;
1400                                                         shift @{$tochan->{pingtime}} if @{$tochan->{pingtime}} > 6;
1401
1402                                                                 # cope with a missed ping, this means you must set the pingint large enough
1403                                                         if ($t > $tochan->{pingint}  && $t < 2 * $tochan->{pingint} ) {
1404                                                                 $t -= $tochan->{pingint};
1405                                                         }
1406
1407                                                                 # calc smoothed RTT a la TCP
1408                                                         if (@{$tochan->{pingtime}} == 1) {
1409                                                                 $tochan->{pingave} = $t;
1410                                                         } else {
1411                                                                 $tochan->{pingave} = $tochan->{pingave} + (($t - $tochan->{pingave}) / 6);
1412                                                         }
1413                                                         my $rref = Route::Node::get($tochan->{call});
1414                                                         $rref->pingtime($tochan->{pingave}) if $rref;
1415                                                         $tochan->{nopings} = $nopings; # pump up the timer
1416                                                 } elsif (my $rref = Route::Node::get($r->{call})) {
1417                                                         if (defined $rref->pingtime) {
1418                                                                 $rref->pingtime($rref->pingtime + (($t - $rref->pingtime) / 6));
1419                                                         } else {
1420                                                                 $rref->pingtime($t);
1421                                                         }
1422                                                 }
1423                                         }
1424                                 }
1425                         }
1426                 }
1427         } else {
1428                 if (eph_dup($line)) {
1429                         dbg("PCPROT: dup PC51 detected") if isdbg('chanerr');
1430                         return;
1431                 }
1432                 # route down an appropriate thingy
1433                 $self->route($to, $line);
1434         }
1435 }
1436
1437 # New style routing handler
1438 sub handle_59
1439 {
1440         my $self = shift;
1441         my $pcno = shift;
1442         my $line = shift;
1443         my $origin = shift;
1444
1445         my ($sort, $hextime, $ncall) = @_[1,2,3];
1446         if ($ncall eq $main::mycall) {
1447                 dbg("PCPROT: ignoring PC59 for me") if isdbg('chan');
1448                 return;
1449         }
1450
1451         # do this once for filtering with a throwaway routing entry if a new node
1452         my $fnode = Route::Node::get($ncall) || Route::new($ncall);
1453         return unless $self->in_filter_route($fnode);
1454
1455         return if eph_dup($line);
1456
1457         # mark myself as NewRoute if I get a PC59
1458         $self->{newroute} = 1 if $ncall eq $self->{call};
1459
1460         # now do it properly for actions
1461         my $node = Route::Node::get($ncall) || Route::Node->new($ncall);
1462         $node->newroute(1);
1463
1464         # find each of the entries (or create new ones)
1465         my @refs;
1466         for my $ent (@_[4..$#_]) {
1467                 next if $ent =~ /^H\d+$/;
1468
1469                 my ($esort, $ehere, $ecall) = unpack "A A A*", $ent;
1470                 my $ref;
1471
1472                 next unless $esort && defined $ehere && $ecall;
1473
1474                 # create user, if required
1475                 my $user = DXUser->get_current($ecall);
1476                 unless ($user) {
1477                         $user = DXUser->new($ecall);
1478                         $user->sort();
1479                         $user->priv(1);         # I have relented and defaulted nodes
1480                         $user->lockout(1);
1481                         $user->homenode($ncall);
1482                         $user->node($ncall);
1483                 }
1484                 if ($esort eq 'U') {
1485                         $ref = Route::User::get($ecall);
1486                         unless ($ref) {
1487                                 # create user, if required
1488                                 my $user = DXUser->get_current($ecall);
1489                                 unless ($user) {
1490                                         $user = DXUser->new($ecall);
1491                                         $user->sort('U');
1492                                         $user->homenode($ncall);
1493                                         $user->node($ncall);
1494                                         $user->put;
1495                                 }
1496                                 $ref = Route::User->new($ecall, 0);
1497                         }
1498                 } elsif ($esort eq 'N') {
1499                         $ref = Route::Node::get($ecall);
1500                         unless ($ref) {
1501                                 # create user, if required
1502                                 my $user = DXUser->get_current($ecall);
1503                                 unless ($user) {
1504                                         $user = DXUser->new($ecall);
1505                                         $user->priv(1);         # I have relented and defaulted nodes
1506                                         $user->lockout(1);
1507                                         $user->sort('A');
1508                                         $user->homenode($ncall);
1509                                         $user->node($ncall);
1510                                         $user->put;
1511                                 }
1512                                 $ref = Route::Node->new($ecall, 0);
1513                         }
1514                 } else {
1515                         dbg("DXPROT: unknown entity type '$esort' on $ecall for node $ncall") if isdbg('chan');
1516                         next;
1517                 }
1518                 $ref->here($ehere);             # might as well set this here
1519                 $ref->lastseen($main::systime);
1520                 push @refs, $ref;
1521         }
1522
1523         # if it is a delete, disconnect all the entries mentioned
1524         # from this node (which is a parent in this context).
1525         my @delnode;
1526         my @deluser;
1527         if ($sort eq 'D') {
1528                 for my $ref (@refs) {
1529                         next if $ref->call eq $ncall;
1530                         next if $ref->call eq $main::mycall;
1531                         if ($ref->isa('Route::Node')) {
1532                                 push @delnode, $node->unlink_node($ref, $self);
1533                         } elsif ($ref->isa('Route::User')) {
1534                                 push @deluser, $node->del_user($ref);
1535                         }
1536                 }
1537         }
1538
1539         # if it is an add, connect all the entries
1540         my @addnode;
1541         my @adduser;
1542         if ($sort eq 'A') {
1543                 for my $ref (@refs) {
1544                         next if $ref->call eq $ncall;
1545                         next if $ref->call eq $main::mycall;
1546                         if ($ref->isa('Route::Node')) {
1547                                 my $new = $node->link_node($ref, $self);
1548                                 push @addnode, $new if $new;
1549                         } elsif ($ref->isa('Route::User')) {
1550                                 push @adduser, $node->del_user($ref);
1551                         }
1552                 }
1553         }
1554
1555         # if it is a configure, unlink all the nodes and users that
1556         # are not in @refs but are in the node, then add all the
1557         # nodes and users that are @refs but not in the node.
1558         #
1559         if ($sort eq 'C') {
1560                 my @dn;
1561                 my @du;
1562                 my @an;
1563                 my @au;
1564                 for my $r (map {Route::Node::get($_)} $node->nodes) {
1565                         next unless $r;
1566                         next if $r->call eq $ncall;
1567                         next if $r->call eq $main::mycall;
1568                         push @dn, $r unless grep $_->call eq $r->call, @refs;
1569                 }
1570                 for my $r (map {Route::User::get($_)} $node->users) {
1571                         next unless $r;
1572                         push @du, $r unless grep $_->call eq $r->call, @refs;
1573                 }
1574                 for my $r (@refs) {
1575                         next unless $r;
1576                         next if $r->call eq $ncall;
1577                         next if $r->call eq $main::mycall;
1578                         if ($r->isa('Route::Node')) {
1579                                 push @an, $r unless grep $r->call eq $_, $node->nodes;
1580                         } elsif ($r->isa('Route::User')) {
1581                                 push @au, $r unless grep $r->call eq $_, $node->users;
1582                         }
1583                 }
1584                 push @delnode, $node->unlink_node($_, $self) for @dn;
1585                 push @deluser, $node->del_user($_) for @du;
1586                 push @addnode, $node->link_node($_, $self) for @an;
1587                 push @adduser, $node->add_user($_) for @au;
1588         }
1589
1590         $self->route_pc21($origin, $line, @delnode) if @delnode;
1591         $self->route_pc19($origin, $line, @addnode) if @addnode;
1592         $self->route_pc17($origin, $line, @deluser) if @deluser;
1593         $self->route_pc16($origin, $line, @adduser) if @adduser;
1594
1595         $self->route_pc59($sort, $hextime, $ncall, @refs) if @refs;
1596         $_->delete for @delnode, @deluser;
1597 }
1598
1599
1600 # dunno but route it
1601 sub handle_75
1602 {
1603         my $self = shift;
1604         my $pcno = shift;
1605         my $line = shift;
1606         my $origin = shift;
1607         my $call = $_[1];
1608         if ($call ne $main::mycall) {
1609                 $self->route($call, $line);
1610         }
1611 }
1612
1613 # WCY broadcasts
1614 sub handle_73
1615 {
1616         my $self = shift;
1617         my $pcno = shift;
1618         my $line = shift;
1619         my $origin = shift;
1620         my $call = $_[1];
1621
1622         # do some de-duping
1623         my $d = cltounix($call, sprintf("%02d18Z", $_[2]));
1624         if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $_[2] < 0 || $_[2] > 23) {
1625                 dbg("PCPROT: WCY Date ($call $_[2]) out of range") if isdbg('chanerr');
1626                 return;
1627         }
1628         @_ = map { unpad($_) } @_;
1629         if (WCY::dup($d)) {
1630                 dbg("PCPROT: Dup WCY Spot ignored\n") if isdbg('chanerr');
1631                 return;
1632         }
1633
1634         my $wcy = WCY::update($d, @_[2..12]);
1635
1636         my $rep;
1637         eval {
1638                 $rep = Local::wcy($self, @_[1..12]);
1639         };
1640         # dbg("Local::wcy error $@") if isdbg('local') if $@;
1641         return if $rep;
1642
1643         # broadcast to the eager world
1644         send_wcy_spot($self, $line, $d, @_[2..12]);
1645 }
1646
1647 # remote commands (incoming)
1648 sub handle_84
1649 {
1650         my $self = shift;
1651         my $pcno = shift;
1652         my $line = shift;
1653         my $origin = shift;
1654         $self->process_rcmd($_[1], $_[2], $_[3], $_[4]);
1655 }
1656
1657 # remote command replies
1658 sub handle_85
1659 {
1660         my $self = shift;
1661         my $pcno = shift;
1662         my $line = shift;
1663         my $origin = shift;
1664         $self->process_rcmd_reply($_[1], $_[2], $_[3], $_[4]);
1665 }
1666
1667 # if get here then rebroadcast the thing with its Hop count decremented (if
1668 # there is one). If it has a hop count and it decrements to zero then don't
1669 # rebroadcast it.
1670 #
1671 # NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be
1672 #        REBROADCAST!!!!
1673 #
1674
1675 sub handle_default
1676 {
1677         my $self = shift;
1678         my $pcno = shift;
1679         my $line = shift;
1680         my $origin = shift;
1681
1682         if (eph_dup($line)) {
1683                 dbg("PCPROT: Ephemeral dup, dropped") if isdbg('chanerr');
1684         } else {
1685                 unless ($self->{isolate}) {
1686                         DXChannel::broadcast_nodes($line, $self) if $line =~ /\^H\d+\^?~?$/; # send it to everyone but me
1687                 }
1688         }
1689 }
1690
1691 #
1692 # This is called from inside the main cluster processing loop and is used
1693 # for despatching commands that are doing some long processing job
1694 #
1695 sub process
1696 {
1697         my $t = time;
1698         my @dxchan = DXChannel->get_all();
1699         my $dxchan;
1700         my $pc50s;
1701
1702         # send out a pc50 on EVERY channel all at once
1703         if ($t >= $last_pc50 + $DXProt::pc50_interval) {
1704                 $pc50s = pc50($main::me, scalar DXChannel::get_all_users);
1705                 eph_dup($pc50s);
1706                 $last_pc50 = $t;
1707         }
1708
1709         foreach $dxchan (@dxchan) {
1710                 next unless $dxchan->is_node();
1711                 next if $dxchan == $main::me;
1712
1713                 # send the pc50
1714                 $dxchan->send($pc50s) if $pc50s;
1715
1716                 # send a ping out on this channel
1717                 if ($dxchan->{pingint} && $t >= $dxchan->{pingint} + $dxchan->{lastping}) {
1718                         if ($dxchan->{nopings} <= 0) {
1719                                 $dxchan->disconnect;
1720                         } else {
1721                                 addping($main::mycall, $dxchan->call);
1722                                 $dxchan->{nopings} -= 1;
1723                                 $dxchan->{lastping} = $t;
1724                         }
1725                 }
1726         }
1727
1728         # every ten seconds
1729         if ($t - $last10 >= 10) {
1730                 # clean out ephemera
1731
1732                 eph_clean();
1733
1734                 $last10 = $t;
1735         }
1736
1737         if ($main::systime - 3600 > $last_hour) {
1738                 $last_hour = $main::systime;
1739         }
1740 }
1741
1742 #
1743 # finish up a pc context
1744 #
1745
1746 #
1747 # some active measures
1748 #
1749
1750
1751 sub send_dx_spot
1752 {
1753         my $self = shift;
1754         my $line = shift;
1755         my @dxchan = DXChannel->get_all();
1756         my $dxchan;
1757
1758         # send it if it isn't the except list and isn't isolated and still has a hop count
1759         # taking into account filtering and so on
1760         foreach $dxchan (@dxchan) {
1761                 next if $dxchan == $main::me;
1762                 next if $dxchan == $self && $self->is_node;
1763                 $dxchan->dx_spot($line, $self->{isolate}, @_, $self->{call});
1764         }
1765 }
1766
1767 sub dx_spot
1768 {
1769         my $self = shift;
1770         my $line = shift;
1771         my $isolate = shift;
1772         my ($filter, $hops);
1773
1774         if ($self->{spotsfilter}) {
1775                 ($filter, $hops) = $self->{spotsfilter}->it(@_);
1776                 return unless $filter;
1777         }
1778         send_prot_line($self, $filter, $hops, $isolate, $line);
1779 }
1780
1781 sub send_prot_line
1782 {
1783         my ($self, $filter, $hops, $isolate, $line) = @_;
1784         my $routeit;
1785
1786
1787         if ($hops) {
1788                 $routeit = $line;
1789                 $routeit =~ s/\^H\d+\^\~$/\^H$hops\^\~/;
1790         } else {
1791                 $routeit = adjust_hops($self, $line);  # adjust its hop count by node name
1792                 return unless $routeit;
1793         }
1794         if ($filter) {
1795                 $self->send($routeit);
1796         } else {
1797                 $self->send($routeit) unless $self->{isolate} || $isolate;
1798         }
1799 }
1800
1801
1802 sub send_wwv_spot
1803 {
1804         my $self = shift;
1805         my $line = shift;
1806         my @dxchan = DXChannel->get_all();
1807         my $dxchan;
1808         my @dxcc = ((Prefix::cty_data($_[6]))[0..2], (Prefix::cty_data($_[7]))[0..2]);
1809
1810         # send it if it isn't the except list and isn't isolated and still has a hop count
1811         # taking into account filtering and so on
1812         foreach $dxchan (@dxchan) {
1813                 next if $dxchan == $main::me;
1814                 next if $dxchan == $self && $self->is_node;
1815                 my $routeit;
1816                 my ($filter, $hops);
1817
1818                 $dxchan->wwv($line, $self->{isolate}, @_, $self->{call}, @dxcc);
1819         }
1820 }
1821
1822 sub wwv
1823 {
1824         my $self = shift;
1825         my $line = shift;
1826         my $isolate = shift;
1827         my ($filter, $hops);
1828
1829         if ($self->{wwvfilter}) {
1830                 ($filter, $hops) = $self->{wwvfilter}->it(@_);
1831                 return unless $filter;
1832         }
1833         send_prot_line($self, $filter, $hops, $isolate, $line)
1834 }
1835
1836 sub send_wcy_spot
1837 {
1838         my $self = shift;
1839         my $line = shift;
1840         my @dxchan = DXChannel->get_all();
1841         my $dxchan;
1842         my @dxcc = ((Prefix::cty_data($_[10]))[0..2], (Prefix::cty_data($_[11]))[0..2]);
1843
1844         # send it if it isn't the except list and isn't isolated and still has a hop count
1845         # taking into account filtering and so on
1846         foreach $dxchan (@dxchan) {
1847                 next if $dxchan == $main::me;
1848                 next if $dxchan == $self;
1849
1850                 $dxchan->wcy($line, $self->{isolate}, @_, $self->{call}, @dxcc);
1851         }
1852 }
1853
1854 sub wcy
1855 {
1856         my $self = shift;
1857         my $line = shift;
1858         my $isolate = shift;
1859         my ($filter, $hops);
1860
1861         if ($self->{wcyfilter}) {
1862                 ($filter, $hops) = $self->{wcyfilter}->it(@_);
1863                 return unless $filter;
1864         }
1865         send_prot_line($self, $filter, $hops, $isolate, $line) if $self->is_clx || $self->is_spider || $self->is_dxnet;
1866 }
1867
1868 # send an announce
1869 sub send_announce
1870 {
1871         my $self = shift;
1872         my $line = shift;
1873         my @dxchan = DXChannel->get_all();
1874         my $dxchan;
1875         my $target;
1876         my $to = 'To ';
1877         my $text = unpad($_[2]);
1878
1879         if ($_[3] eq '*') {     # sysops
1880                 $target = "SYSOP";
1881         } elsif ($_[3] gt ' ') { # speciality list handling
1882                 my ($name) = split /\./, $_[3];
1883                 $target = "$name"; # put the rest in later (if bothered)
1884         }
1885
1886         if ($_[5] eq '1') {
1887                 $target = "WX";
1888                 $to = '';
1889         }
1890         $target = "ALL" if !$target;
1891
1892
1893         # obtain country codes etc
1894         my @a = Prefix::cty_data($_[0]);
1895         my @b = Prefix::cty_data($_[4]);
1896         if ($self->{inannfilter}) {
1897                 my ($filter, $hops) =
1898                         $self->{inannfilter}->it(@_, $self->{call},
1899                                                                          @a[0..2],
1900                                                                          @b[0..2], $a[3], $b[3]);
1901                 unless ($filter) {
1902                         dbg("PCPROT: Rejected by input announce filter") if isdbg('chanerr');
1903                         return;
1904                 }
1905         }
1906
1907         if (AnnTalk::dup($_[0], $_[1], $_[2])) {
1908                 dbg("PCPROT: Duplicate Announce ignored") if isdbg('chanerr');
1909                 return;
1910         }
1911
1912         Log('ann', $target, $_[0], $text);
1913
1914         # send it if it isn't the except list and isn't isolated and still has a hop count
1915         # taking into account filtering and so on
1916         foreach $dxchan (@dxchan) {
1917                 next if $dxchan == $main::me;
1918                 next if $dxchan == $self && $self->is_node;
1919                 $dxchan->announce($line, $self->{isolate}, $to, $target, $text, @_, $self->{call},
1920                                                   @a[0..2], @b[0..2]);
1921         }
1922 }
1923
1924 my $msgid = 0;
1925
1926 sub nextchatmsgid
1927 {
1928         $msgid++;
1929         $msgid = 1 if $msgid > 999;
1930         return $msgid;
1931 }
1932
1933 # send a chat line
1934 sub send_chat
1935 {
1936         my $self = shift;
1937         my $line = shift;
1938         my @dxchan = DXChannel->get_all();
1939         my $dxchan;
1940         my $target = $_[3];
1941         my $text = unpad($_[2]);
1942         my $ak1a_line;
1943
1944         # munge the group and recast the line if required
1945         if ($target =~ s/\.LST$//) {
1946                 $ak1a_line = $line;
1947         }
1948
1949         # obtain country codes etc
1950         my @a = Prefix::cty_data($_[0]);
1951         my @b = Prefix::cty_data($_[4]);
1952         if ($self->{inannfilter}) {
1953                 my ($filter, $hops) =
1954                         $self->{inannfilter}->it(@_, $self->{call},
1955                                                                          @a[0..2],
1956                                                                          @b[0..2], $a[3], $b[3]);
1957                 unless ($filter) {
1958                         dbg("PCPROT: Rejected by input announce filter") if isdbg('chanerr');
1959                         return;
1960                 }
1961         }
1962
1963         if (AnnTalk::dup($_[0], $_[1], $_[2], $chatdupeage)) {
1964                 dbg("PCPROT: Duplicate Announce ignored") if isdbg('chanerr');
1965                 return;
1966         }
1967
1968
1969         Log('chat', $target, $_[0], $text);
1970
1971         # send it if it isn't the except list and isn't isolated and still has a hop count
1972         # taking into account filtering and so on
1973         foreach $dxchan (@dxchan) {
1974                 my $is_ak1a = $dxchan->is_ak1a;
1975
1976                 if ($dxchan->is_node) {
1977                         next if $dxchan == $main::me;
1978                         next if $dxchan == $self;
1979                         next unless $dxchan->is_spider || $is_ak1a;
1980                         next if $target eq 'LOCAL';
1981                         if (!$ak1a_line && $is_ak1a) {
1982                                 $ak1a_line = DXProt::pc12($_[0], $text, $_[1], "$target.LST");
1983                         }
1984                 }
1985
1986                 $dxchan->chat($is_ak1a ? $ak1a_line : $line, $self->{isolate}, $target, $_[1],
1987                                           $text, @_, $self->{call}, @a[0..2], @b[0..2]);
1988         }
1989 }
1990
1991 sub announce
1992 {
1993         my $self = shift;
1994         my $line = shift;
1995         my $isolate = shift;
1996         my $to = shift;
1997         my $target = shift;
1998         my $text = shift;
1999         my ($filter, $hops);
2000
2001         if ($self->{annfilter}) {
2002                 ($filter, $hops) = $self->{annfilter}->it(@_);
2003                 return unless $filter;
2004         }
2005         send_prot_line($self, $filter, $hops, $isolate, $line) unless $_[1] eq $main::mycall;
2006 }
2007
2008 sub chat
2009 {
2010         goto &announce;
2011 }
2012
2013
2014 sub send_local_config
2015 {
2016         my $self = shift;
2017         my $node;
2018         my @nodes;
2019         my @localnodes;
2020         my @remotenodes;
2021
2022         dbg('DXProt::send_local_config') if isdbg('trace');
2023
2024         if ($self->{newroute}) {
2025                 my @nodes = $self->{isolate} ? ($main::routeroot) : grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} } DXChannel::get_all_nodes();
2026                 my @users = DXChannel::get_all_users();
2027                 @localnodes = map { Route::Node::get($_->{call}) } @nodes;
2028                 my @localusers = map { Route::User::get($_->{call}) } @users;
2029                 $self->send_route($main::mycall, \&pc59, @nodes+@users+4, 'C', 0, $main::mycall, $main::routeroot, @localnodes, @localusers);
2030         } else {
2031                 # send our nodes
2032                 if ($self->{isolate}) {
2033                         @localnodes = ( $main::routeroot );
2034                         $self->send_route($main::mycall, \&pc19, 1, $main::routeroot);
2035                 } else {
2036                         # create a list of all the nodes that are not connected to this connection
2037                         # and are not themselves isolated, this to make sure that isolated nodes
2038                         # don't appear outside of this node
2039
2040                         # send locally connected nodes
2041                         my @dxchan = grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} } DXChannel::get_all_nodes();
2042                         @localnodes = map { my $r = Route::Node::get($_->{call}); $r ? $r : () } @dxchan if @dxchan;
2043                         $self->send_route($main::mycall, \&pc19, scalar(@localnodes)+1, $main::routeroot, @localnodes);
2044
2045                         my $node;
2046                         my @rawintcalls = map { $_->nodes } @localnodes if @localnodes;
2047                         my @intcalls;
2048                         for $node (@rawintcalls) {
2049                                 push @intcalls, $node unless grep $node eq $_, @intcalls;
2050                         }
2051                         my $ref = Route::Node::get($self->{call});
2052                         my @rnodes = $ref->nodes;
2053                         for $node (@intcalls) {
2054                                 push @remotenodes, Route::Node::get($node) unless grep $node eq $_, @rnodes, @remotenodes;
2055                         }
2056                         $self->send_route($main::mycall, \&pc19, scalar(@remotenodes), @remotenodes);
2057                 }
2058
2059                 # get all the users connected on the above nodes and send them out
2060                 foreach $node ($main::routeroot, @localnodes, @remotenodes) {
2061                         if ($node) {
2062                                 my @rout = map {my $r = Route::User::get($_); $r ? ($r) : ()} $node->users;
2063                                 $self->send_route($main::mycall, \&pc16, 1, $node, @rout) if @rout && $self->user->wantsendpc16;
2064                         } else {
2065                                 dbg("sent a null value") if isdbg('chanerr');
2066                         }
2067                 }
2068         }
2069 }
2070
2071 #
2072 # route a message down an appropriate interface for a callsign
2073 #
2074 # is called route(to, pcline);
2075 #
2076 sub route
2077 {
2078         my ($self, $call, $line) = @_;
2079
2080         if (ref $self && $call eq $self->{call}) {
2081                 dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr');
2082                 return;
2083         }
2084
2085         # always send it down the local interface if available
2086         my $dxchan = DXChannel->get($call);
2087         unless ($dxchan) {
2088                 my $cl = Route::get($call);
2089                 $dxchan = $cl->bestdxchan if $cl;
2090                 if (ref $dxchan) {
2091                         if (ref $self && $dxchan eq $self) {
2092                                 dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr');
2093                                 return;
2094                         }
2095                 }
2096         }
2097         if ($dxchan) {
2098                 my $routeit = adjust_hops($dxchan, $line);   # adjust its hop count by node name
2099                 if ($routeit) {
2100                         $dxchan->send($routeit) unless $dxchan == $main::me;
2101                 }
2102         } else {
2103                 dbg("PCPROT: No route available, dropped") if isdbg('chanerr');
2104         }
2105 }
2106
2107 #
2108 # obtain the hops from the list for this callsign and pc no
2109 #
2110
2111 sub get_hops
2112 {
2113         my $pcno = shift;
2114         my $hops = $DXProt::hopcount{$pcno};
2115         $hops = $DXProt::def_hopcount if !$hops;
2116         return "H$hops";
2117 }
2118
2119 #
2120 # adjust the hop count on a per node basis using the user loadable
2121 # hop table if available or else decrement an existing one
2122 #
2123
2124 sub adjust_hops
2125 {
2126         my $self = shift;
2127         my $s = shift;
2128         my $call = $self->{call};
2129         my $hops;
2130
2131         if (($hops) = $s =~ /\^H(\d+)\^~?$/o) {
2132                 my ($pcno) = $s =~ /^PC(\d\d)/o;
2133                 confess "$call called adjust_hops with '$s'" unless $pcno;
2134                 my $ref = $nodehops{$call} if %nodehops;
2135                 if ($ref) {
2136                         my $newhops = $ref->{$pcno};
2137                         return "" if defined $newhops && $newhops == 0;
2138                         $newhops = $ref->{default} unless $newhops;
2139                         return "" if defined $newhops && $newhops == 0;
2140                         $newhops = $hops if !$newhops;
2141                         $s =~ s/\^H(\d+)(\^~?)$/\^H$newhops$2/ if $newhops;
2142                 } else {
2143                         # simply decrement it
2144                         $hops--;
2145                         return "" if !$hops;
2146                         $s =~ s/\^H(\d+)(\^~?)$/\^H$hops$2/ if $hops;
2147                 }
2148         }
2149         return $s;
2150 }
2151
2152 #
2153 # load hop tables
2154 #
2155 sub load_hops
2156 {
2157         my $self = shift;
2158         return $self->msg('lh1') unless -e "$main::data/hop_table.pl";
2159         do "$main::data/hop_table.pl";
2160         return $@ if $@;
2161         return ();
2162 }
2163
2164
2165 # add a ping request to the ping queues
2166 sub addping
2167 {
2168         my ($from, $to) = @_;
2169         my $ref = $pings{$to} || [];
2170         my $r = {};
2171         $r->{call} = $from;
2172         $r->{t} = [ gettimeofday ];
2173         route(undef, $to, pc51($to, $main::mycall, 1));
2174         push @$ref, $r;
2175         $pings{$to} = $ref;
2176         my $u = DXUser->get_current($to);
2177         $u->lastping($main::systime) if $u;
2178 }
2179
2180 sub process_rcmd
2181 {
2182         my ($self, $tonode, $fromnode, $user, $cmd) = @_;
2183         if ($tonode eq $main::mycall) {
2184                 my $ref = DXUser->get_current($fromnode);
2185                 my $cref = Route::Node::get($fromnode);
2186                 Log('rcmd', 'in', $ref->{priv}, $fromnode, $cmd);
2187                 if ($cmd !~ /^\s*rcmd/i && $cref && $ref && $cref->call eq $ref->homenode) { # not allowed to relay RCMDS!
2188                         if ($ref->{priv}) {             # you have to have SOME privilege, the commands have further filtering
2189                                 $self->{remotecmd} = 1; # for the benefit of any command that needs to know
2190                                 my $oldpriv = $self->{priv};
2191                                 $self->{priv} = $ref->{priv}; # assume the user's privilege level
2192                                 my @in = (DXCommandmode::run_cmd($self, $cmd));
2193                                 $self->{priv} = $oldpriv;
2194                                 $self->send_rcmd_reply($main::mycall, $fromnode, $user, @in);
2195                                 delete $self->{remotecmd};
2196                         } else {
2197                                 $self->send_rcmd_reply($main::mycall, $fromnode, $user, "sorry...!");
2198                         }
2199                 } else {
2200                         $self->send_rcmd_reply($main::mycall, $fromnode, $user, "your attempt is logged, Tut tut tut...!");
2201                 }
2202         } else {
2203                 my $ref = DXUser->get_current($tonode);
2204                 if ($ref && $ref->is_clx) {
2205                         $self->route($tonode, pc84($fromnode, $tonode, $user, $cmd));
2206                 } else {
2207                         $self->route($tonode, pc34($fromnode, $tonode, $cmd));
2208                 }
2209         }
2210 }
2211
2212 sub process_rcmd_reply
2213 {
2214         my ($self, $tonode, $fromnode, $user, $line) = @_;
2215         if ($tonode eq $main::mycall) {
2216                 my $s = $rcmds{$fromnode};
2217                 if ($s) {
2218                         my $dxchan = DXChannel->get($s->{call});
2219                         my $ref = $user eq $tonode ? $dxchan : (DXChannel->get($user) || $dxchan);
2220                         $ref->send($line) if $ref;
2221                         delete $rcmds{$fromnode} if !$dxchan;
2222                 } else {
2223                         # send unsolicited ones to the sysop
2224                         my $dxchan = DXChannel->get($main::myalias);
2225                         $dxchan->send($line) if $dxchan;
2226                 }
2227         } else {
2228                 my $ref = DXUser->get_current($tonode);
2229                 if ($ref && $ref->is_clx) {
2230                         $self->route($tonode, pc85($fromnode, $tonode, $user, $line));
2231                 } else {
2232                         $self->route($tonode, pc35($fromnode, $tonode, $line));
2233                 }
2234         }
2235 }
2236
2237 sub send_rcmd_reply
2238 {
2239         my $self = shift;
2240         my $tonode = shift;
2241         my $fromnode = shift;
2242         my $user = shift;
2243         while (@_) {
2244                 my $line = shift;
2245                 $line =~ s/\s*$//;
2246                 Log('rcmd', 'out', $fromnode, $line);
2247                 if ($self->is_clx) {
2248                         $self->send(pc85($main::mycall, $fromnode, $user, "$main::mycall:$line"));
2249                 } else {
2250                         $self->send(pc35($main::mycall, $fromnode, "$main::mycall:$line"));
2251                 }
2252         }
2253 }
2254
2255 # add a rcmd request to the rcmd queues
2256 sub addrcmd
2257 {
2258         my ($self, $to, $cmd) = @_;
2259
2260         my $r = {};
2261         $r->{call} = $self->{call};
2262         $r->{t} = $main::systime;
2263         $r->{cmd} = $cmd;
2264         $rcmds{$to} = $r;
2265
2266         my $ref = Route::Node::get($to);
2267         my $dxchan = $ref->bestdxchan;
2268         if ($dxchan && $dxchan->is_clx) {
2269                 route(undef, $to, pc84($main::mycall, $to, $self->{call}, $cmd));
2270         } else {
2271                 route(undef, $to, pc34($main::mycall, $to, $cmd));
2272         }
2273 }
2274
2275 sub disconnect
2276 {
2277         my $self = shift;
2278         my $pc39flag = shift;
2279         my $call = $self->call;
2280
2281         return if $self->{disconnecting}++;
2282
2283         unless ($pc39flag && $pc39flag == 1) {
2284                 $self->send_now("D", DXProt::pc39($main::mycall, $self->msg('disc1', "System Op")));
2285         }
2286
2287         # get rid of any PC16/17/19
2288         eph_del_regex("^PC1[679]*$call");
2289
2290         # do routing stuff, remove me from routing table
2291         my $node = Route::Node::get($call);
2292         my @rout;
2293         if ($node) {
2294
2295                 # remove the route from this node and return a list
2296                 # of nodes that have become orphanned as a result.
2297                 push @rout, $main::routeroot->remove_route($node, $self);
2298
2299                 # remove all my ephemera as well
2300                 for (@rout) {
2301                         my $c = $_->call;
2302                         eph_del_regex("^PC1[679].*$c");
2303                 }
2304         }
2305
2306         # unbusy and stop and outgoing mail
2307         my $mref = DXMsg::get_busy($call);
2308         $mref->stop_msg($call) if $mref;
2309
2310         # broadcast to all other nodes that all the nodes connected to via me are gone
2311         unless ($pc39flag && $pc39flag == 2) {
2312                 $self->route_pc21($main::mycall, undef, @rout) if @rout;
2313                 $self->route_pc59('D', 0, $main::mycall, $node);
2314         }
2315
2316         # delete all the unwanted nodes
2317         $_->delete for @rout;
2318
2319         # remove outstanding pings
2320         delete $pings{$call};
2321
2322         # I was the last node visited
2323     $self->user->node($main::mycall);
2324
2325         # send info to all logged in thingies
2326         $self->tell_login('logoutn');
2327
2328         Log('DXProt', $call . " Disconnected");
2329
2330         $self->SUPER::disconnect;
2331 }
2332
2333
2334 #
2335 # send a talk message to this thingy
2336 #
2337 sub talk
2338 {
2339         my ($self, $from, $to, $via, $line, $origin) = @_;
2340
2341         $line =~ s/\^/\\5E/g;                   # remove any ^ characters
2342         $self->send(DXProt::pc10($from, $to, $via, $line, $origin));
2343         Log('talk', $to, $from, $via?$via:$self->call, $line) unless $origin && $origin ne $main::mycall;
2344 }
2345
2346 # send it if it isn't the except list and isn't isolated and still has a hop count
2347 # taking into account filtering and so on
2348
2349 sub send_route
2350 {
2351         my $self = shift;
2352         my $origin = shift;
2353         my $generate = shift;
2354         my $no = shift;     # the no of things to filter on
2355         my $routeit;
2356         my ($filter, $hops);
2357         my @rin;
2358
2359         for (; @_ && $no; $no--) {
2360                 my $r = shift;
2361
2362                 # deal with non routing parameters
2363                 unless (ref $r && $r->isa('Route')) {
2364                         push @rin, $r;
2365                         next;
2366                 }
2367
2368                 if (!$self->{isolate} && $self->{routefilter}) {
2369                         $filter = undef;
2370                         if ($r) {
2371                                 ($filter, $hops) = $self->{routefilter}->it($self->{call}, $self->{dxcc}, $self->{itu}, $self->{cq}, $r->call, $r->dxcc, $r->itu, $r->cq, $self->{state}, $r->{state});
2372                                 if ($filter) {
2373                                         push @rin, $r;
2374                                 } else {
2375                                         dbg("DXPROT: $self->{call}/" . $r->call . " rejected by output filter") if isdbg('chanerr');
2376                                 }
2377                         } else {
2378                                 dbg("was sent a null value") if isdbg('chanerr');
2379                         }
2380                 } else {
2381                         push @rin, $r unless $self->{isolate} && $r->call ne $main::mycall;
2382                 }
2383         }
2384         if (@rin) {
2385                 foreach my $line (&$generate(@rin, @_)) {
2386                         if ($hops) {
2387                                 $routeit = $line;
2388                                 $routeit =~ s/\^H\d+\^\~$/\^H$hops\^\~/;
2389                         } else {
2390                                 $routeit = adjust_hops($self, $line);  # adjust its hop count by node name
2391                                 next unless $routeit;
2392                         }
2393
2394                         $self->send($routeit);
2395                 }
2396         }
2397 }
2398
2399 sub broadcast_route
2400 {
2401         my $self = shift;
2402         my $origin = shift;
2403         my $generate = shift;
2404         my $line = shift;
2405         my @dxchan = DXChannel::get_all_nodes();
2406         my $dxchan;
2407
2408         unless ($self->{isolate}) {
2409                 foreach $dxchan (@dxchan) {
2410                         next if $dxchan == $self;
2411                         next if $dxchan == $main::me;
2412                         next unless $dxchan->isa('DXProt');
2413                         next if ($generate == \&pc16 || $generate==\&pc17) && !$dxchan->user->wantsendpc16;
2414                         if ($dxchan->{newroute}) {
2415                                 next if ($generate == \&pc19 || $generate==\&pc21);
2416                         } else {
2417                                 next if ($generate == \&pc19 || $generate==\&pc21) && !$dxchan->user->wantroutepc19;
2418                                 next if ($generate == \&pc59);
2419                         }
2420
2421                         $dxchan->send_route($origin, $generate, @_);
2422                 }
2423         }
2424 }
2425
2426 sub route_pc16
2427 {
2428         my $self = shift;
2429         return unless $self->user->wantpc16;
2430         my $origin = shift;
2431         my $line = shift;
2432         broadcast_route($self, $origin, \&pc16, $line, 1, @_);
2433 }
2434
2435 sub route_pc17
2436 {
2437         my $self = shift;
2438         return unless $self->user->wantpc16;
2439         my $origin = shift;
2440         my $line = shift;
2441         broadcast_route($self, $origin, \&pc17, $line, 1, @_);
2442 }
2443
2444 sub route_pc19
2445 {
2446         my $self = shift;
2447         my $origin = shift;
2448         my $line = shift;
2449         broadcast_route($self, $origin, \&pc19, $line, scalar @_, @_);
2450 }
2451
2452 sub route_pc21
2453 {
2454         my $self = shift;
2455         my $origin = shift;
2456         my $line = shift;
2457         broadcast_route($self, $origin, \&pc21, $line, scalar @_, @_);
2458 }
2459
2460 sub route_pc24
2461 {
2462         my $self = shift;
2463         my $origin = shift;
2464         my $line = shift;
2465         broadcast_route($self, $origin, \&pc24, $line, 1, @_);
2466 }
2467
2468 sub route_pc41
2469 {
2470         my $self = shift;
2471         my $origin = shift;
2472         my $line = shift;
2473         broadcast_route($self, $origin, \&pc41, $line, 1, @_);
2474 }
2475
2476 sub route_pc50
2477 {
2478         my $self = shift;
2479         my $origin = shift;
2480         my $line = shift;
2481         broadcast_route($self, $origin, \&pc50, $line, 1, @_);
2482 }
2483
2484 sub route_pc59
2485 {
2486         my $self = shift;
2487         my $origin = shift;
2488         my $line = shift;
2489
2490         broadcast_route($self, $origin, \&pc59, $line, scalar @_, @_);
2491 }
2492
2493 sub in_filter_route
2494 {
2495         my $self = shift;
2496         my $r = shift;
2497         my ($filter, $hops) = (1, 1);
2498
2499         if ($self->{inroutefilter}) {
2500                 ($filter, $hops) = $self->{inroutefilter}->it($self->{call}, $self->{dxcc}, $self->{itu}, $self->{cq}, $r->call, $r->dxcc, $r->itu, $r->cq, $self->state, $r->state);
2501                 dbg("PCPROT: $self->{call}/" . $r->call . ' rejected by in_filter_route') if !$filter && isdbg('chanerr');
2502         }
2503         return $filter;
2504 }
2505
2506 sub eph_dup
2507 {
2508         my $s = shift;
2509         my $t = shift || $eph_restime;
2510         my $r;
2511
2512         # chop the end off
2513         $s =~ s/\^H\d\d?\^?\~?$//;
2514         $r = 1 if exists $eph{$s};    # pump up the dup if it keeps circulating
2515         $eph{$s} = $main::systime + $t;
2516         return $r;
2517 }
2518
2519 sub eph_del_regex
2520 {
2521         my $regex = shift;
2522         my ($key, $val);
2523         while (($key, $val) = each %eph) {
2524                 if ($key =~ m{$regex}) {
2525                         delete $eph{$key};
2526                 }
2527         }
2528 }
2529
2530 sub eph_clean
2531 {
2532         my ($key, $val);
2533
2534         while (($key, $val) = each %eph) {
2535                 if ($main::systime >= $val) {
2536                         delete $eph{$key};
2537                 }
2538         }
2539 }
2540
2541 sub eph_list
2542 {
2543         my ($key, $val);
2544         my @out;
2545
2546         while (($key, $val) = each %eph) {
2547                 push @out, $key, $val;
2548         }
2549         return @out;
2550 }
2551
2552 sub run_cmd
2553 {
2554         goto &DXCommandmode::run_cmd;
2555 }
2556 1;
2557 __END__