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