X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXProt.pm;h=24435bfb691938e6ca4294c8fccec763caecf3c7;hb=refs%2Fheads%2FNewRoute;hp=b0fdd2d9114e49f9338e9a18a999b56ccf4a6ae8;hpb=7f77f123e7b001912474dacac3b3e1a11be8eb7c;p=spider.git diff --git a/perl/DXProt.pm b/perl/DXProt.pm index b0fdd2d9..24435bfb 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -33,18 +33,20 @@ use DXHash; use Route; use Route::Node; use Script; +use Investigate; +use DXProtHandler; use strict; use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); +$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /:\s+(\d+)\.(\d+)/ ); +$BRANCH = sprintf( "%d.%03d", (q$Revision$ =~ /:\s+\d+\.\d+\.(\d+)\.(\d+)/) || (0,0)); $main::build += $VERSION; $main::branch += $BRANCH; use vars qw($pc11_max_age $pc23_max_age $last_pc50 $eph_restime $eph_info_restime $eph_pc34_restime - $last_hour $last10 %eph %pings %rcmds $ann_to_talk - $pingint $obscount %pc19list $chatdupeage + $last_hour $last10 %eph %pings %rcmds $ann_to_talk $pc19_version + $pingint $obscount %pc19list $chatdupeage $investigation_int %nodehops $baddx $badspotter $badnode $censorpc $rspfcheck $allowzero $decode_dk0wcy $send_opernam @checklist); @@ -71,6 +73,9 @@ $eph_pc34_restime = 30; $pingint = 5*60; $obscount = 2; $chatdupeage = 20 * 60 * 60; +$investigation_int = 7*86400; # time between checks to see if we can see this node +$pc19_version = 5466; # the visible version no for outgoing PC19s generated from pc59 + @checklist = ( @@ -199,6 +204,19 @@ sub init { do "$main::data/hop_table.pl" if -e "$main::data/hop_table.pl"; confess $@ if $@; + + my $user = DXUser->get($main::mycall); + $DXProt::myprot_version += $main::version*100; + $main::me = DXProt->SUPER::alloc($main::mycall, 0, $user); + $main::me->{here} = 1; + $main::me->{state} = "indifferent"; + $main::me->{sort} = 'S'; # S for spider + $main::me->{priv} = 9; + $main::me->{metric} = 0; + $main::me->{pingave} = 0; + $main::me->{registered} = 1; + $main::me->{version} = $main::version; + $main::me->{build} = $main::build; } # @@ -207,1475 +225,169 @@ sub init sub new { - my $self = DXChannel::alloc(@_); - - # add this node to the table, the values get filled in later - my $pkg = shift; - my $call = shift; - $main::routeroot->add($call, '5000', Route::here(1)) if $call ne $main::mycall; - - return $self; -} - -# this is how a pc connection starts (for an incoming connection) -# issue a PC38 followed by a PC18, then wait for a PC20 (remembering -# all the crap that comes between). -sub start -{ - my ($self, $line, $sort) = @_; - my $call = $self->{call}; - my $user = $self->{user}; - - # log it - my $host = $self->{conn}->{peerhost} || "unknown"; - Log('DXProt', "$call connected from $host"); - - # remember type of connection - $self->{consort} = $line; - $self->{outbound} = $sort eq 'O'; - my $priv = $user->priv; - $priv = $user->priv(1) unless $priv; - $self->{priv} = $priv; # other clusters can always be 'normal' users - $self->{lang} = $user->lang || 'en'; - $self->{isolate} = $user->{isolate}; - $self->{consort} = $line; # save the connection type - $self->{here} = 1; - $self->{width} = 80; - - # sort out registration - $self->{registered} = 1; - - # get the output filters - $self->{spotsfilter} = Filter::read_in('spots', $call, 0) || Filter::read_in('spots', 'node_default', 0); - $self->{wwvfilter} = Filter::read_in('wwv', $call, 0) || Filter::read_in('wwv', 'node_default', 0); - $self->{wcyfilter} = Filter::read_in('wcy', $call, 0) || Filter::read_in('wcy', 'node_default', 0); - $self->{annfilter} = Filter::read_in('ann', $call, 0) || Filter::read_in('ann', 'node_default', 0) ; - $self->{routefilter} = Filter::read_in('route', $call, 0) || Filter::read_in('route', 'node_default', 0) unless $self->{isolate} ; - - - # get the INPUT filters (these only pertain to Clusters) - $self->{inspotsfilter} = Filter::read_in('spots', $call, 1) || Filter::read_in('spots', 'node_default', 1); - $self->{inwwvfilter} = Filter::read_in('wwv', $call, 1) || Filter::read_in('wwv', 'node_default', 1); - $self->{inwcyfilter} = Filter::read_in('wcy', $call, 1) || Filter::read_in('wcy', 'node_default', 1); - $self->{inannfilter} = Filter::read_in('ann', $call, 1) || Filter::read_in('ann', 'node_default', 1); - $self->{inroutefilter} = Filter::read_in('route', $call, 1) || Filter::read_in('route', 'node_default', 1) unless $self->{isolate}; - - # set unbuffered and no echo - $self->send_now('B',"0"); - $self->send_now('E',"0"); - $self->conn->echo(0) if $self->conn->can('echo'); - - # ping neighbour node stuff - my $ping = $user->pingint; - $ping = $pingint unless defined $ping; - $self->{pingint} = $ping; - $self->{nopings} = $user->nopings || $obscount; - $self->{pingtime} = [ ]; - $self->{pingave} = 999; - $self->{metric} ||= 100; - $self->{lastping} = $main::systime; - - # send initialisation string - unless ($self->{outbound}) { - $self->sendinit; - } - - $self->state('init'); - $self->{pc50_t} = $main::systime; - - # send info to all logged in thingies - $self->tell_login('loginn'); - - # run a script send the output to the debug file - my $script = new Script(lc $call) || new Script('node_default'); - $script->run($self) if $script; -} - -# -# send outgoing 'challenge' -# - -sub sendinit -{ - my $self = shift; - $self->send(pc18()); -} - -sub removepc90 -{ - $_[0] =~ s/^PC90\^[-A-Z0-9]+\^\d+\^//; -} - -sub removepc91 -{ - $_[0] =~ s/^PC91\^[-A-Z0-9]+\^\d+\^[-A-Z0-9]+\^//; -} - -sub send -{ - my $self = shift; - while (@_) { - my $line = shift; - if ($self->user->wantpc90) { - $line = mungepc90($line); - } else { - removepc91($line); - removepc90($line); - } - $self->SUPER::send($line); - } -} - -my $pc90msgid = 0; - -sub nextpc90 -{ - $pc90msgid = 0 if $pc90msgid > 9999; - return $pc90msgid++; -} - -sub mungepc90 -{ - unless ($_[0] =~ /^PC9\d/) { - my $id = nextpc90(); - return "PC90^$main::mycall^$id^" . $_[0]; - } - return $_[0]; -} - -sub mungepc91 -{ - unless ($_[1] =~ /^PC9\d/) { - my $id = nextpc90(); - return "PC91^$main::mycall^$id^$_[0]^" . $_[1]; - } - return $_[1]; -} - -# -# This is the normal pcxx despatcher -# -sub normal -{ - my ($self, $line) = @_; - my @field = split /\^/, $line; - return unless @field; - - pop @field if $field[-1] eq '~'; - -# print join(',', @field), "\n"; - - - # process PC frames, this will fail unless the frame starts PCnn - my ($pcno) = $field[0] =~ /^PC(\d\d)/; # just get the number - unless (defined $pcno && $pcno >= 10 && $pcno <= 99) { - dbg("PCPROT: unknown protocol") if isdbg('chanerr'); - return; - } - - # check for and dump bad protocol messages - my $n = check($pcno, @field); - if ($n) { - dbg("PCPROT: bad field $n, dumped (" . parray($checklist[$pcno-10]) . ")") if isdbg('chanerr'); - return; - } - - # handle PC90 frames in a special way. - # - # PC90 frames are normal frames that that are wrapped in inside a PC90 - # The extra fields are "originating node" and a sequence number. - # The sequence number is checked against the nodes 'last one' to see if - # it is a duplicate and, if so, is dropped at this stage; before any - # other processing. - # - # This is done here simply for efficiency. Adding another function would - # add more copying and so on. - # - - my $origin = $self->{call}; - - if ($pcno >= 90) { - $origin = $field[1]; - if ($origin eq $main::mycall) { - dbg("PCPROT: loop dupe") if isdbg('chanerr'); - return; - } - $self->user->wantpc90(1) unless $self->user->wantpc90 || $origin ne $self->{call}; - my $seq = $field[2]; - my $node = Route::Node::get($origin); - if ($node) { - if (my $lid = $node->lid) { - my $cmp = $seq >= $lid ? $seq : $seq + 9999; - if ($cmp <= $lid) { - dbg("PCPROT: sequence dupe $seq ($cmp) <= $lid") if isdbg('chanerr'); - return; - } - } - $node->lid($seq); - } - - # do a recheck on the contents of the PC90 - if ($pcno >= 90) { - shift @field; - shift @field; - shift @field; - $origin = shift @field if $pcno == 91; - - ($pcno) = $field[0] =~ /^PC(\d\d)/; # just get the number - unless (defined $pcno && $pcno >= 10 && $pcno <= 89) { - dbg("PCPROT: unknown protocol") if isdbg('chanerr'); - return; - } - - # check for and dump bad protocol messages - my $n = check($pcno, @field); - if ($n) { - dbg("PCPROT: bad field $n, dumped (" . parray($checklist[$pcno-10]) . ")") if isdbg('chanerr'); - return; - } - } - } else { - if ($pcno == 16 || $pcno == 17 || $pcno == 19 || $pcno == 21) { - $line = mungepc91($origin, $line); - } else { - $line = mungepc90($line); - } - } - - no strict 'subs'; - my $sub = "handle_$pcno"; - - if ($self->can($sub)) { - $self->$sub($pcno, $line, $origin, @field); - } else { - $self->handle_default($pcno, $line, $origin, @field); - } -} - -# incoming talk commands -sub handle_10 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - # rsfp check - return if $rspfcheck and !$self->rspfcheck(0, $_[6], $_[1]); - - # will we allow it at all? - if ($censorpc) { - my @bad; - if (@bad = BadWords::check($_[3])) { - dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chanerr'); - return; - } - } - - # is it for me or one of mine? - my ($from, $to, $via, $call, $dxchan); - $from = $_[1]; - if ($_[5] gt ' ') { - $via = $_[2]; - $to = $_[5]; - } else { - $to = $_[2]; - } - - # if this is a 'nodx' node then ignore it - if ($badnode->in($_[6]) || ($via && $badnode->in($via))) { - dbg("PCPROT: Bad Node, dropped") if isdbg('chanerr'); - return; - } - - # if this is a 'bad spotter' user then ignore it - my $nossid = $from; - $nossid =~ s/-\d+$//; - if ($badspotter->in($nossid)) { - dbg("PCPROT: Bad Spotter, dropped") if isdbg('chanerr'); - return; - } - - # if we are converting announces to talk is it a dup? - if ($ann_to_talk) { - if (AnnTalk::is_talk_candidate($from, $_[3]) && AnnTalk::dup($from, $to, $_[3])) { - dbg("DXPROT: Dupe talk from announce, dropped") if isdbg('chanerr'); - return; - } - } - - # it is here and logged on - $dxchan = DXChannel->get($main::myalias) if $to eq $main::mycall; - $dxchan = DXChannel->get($to) unless $dxchan; - if ($dxchan && $dxchan->is_user) { - $_[3] =~ s/\%5E/^/g; - $dxchan->talk($from, $to, $via, $_[3]); - return; - } - - # is it elsewhere, visible on the cluster via the to address? - # note: this discards the via unless the to address is on - # the via address - my ($ref, $vref); - if ($ref = Route::get($to)) { - $vref = Route::Node::get($via) if $via; - $vref = undef unless $vref && grep $to eq $_, $vref->users; - $ref->dxchan->talk($from, $to, $vref ? $via : undef, $_[3], $_[6]); - return; - } - - # not visible here, send a message of condolence - $vref = undef; - $ref = Route::get($from); - $vref = $ref = Route::Node::get($_[6]) unless $ref; - if ($ref) { - $dxchan = $ref->dxchan; - $dxchan->talk($main::mycall, $from, $vref ? $vref->call : undef, $dxchan->msg('talknh', $to) ); - } -} - -# DX Spot handling -sub handle_11 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - # route 'foreign' pc26s - if ($pcno == 26) { - if ($_[7] ne $main::mycall) { - $self->route($_[7], $line); - return; - } - } - - # rsfp check - # return if $rspfcheck and !$self->rspfcheck(1, $_[7], $_[6]); - - # if this is a 'nodx' node then ignore it - if ($badnode->in($_[7])) { - dbg("PCPROT: Bad Node, dropped") if isdbg('chanerr'); - return; - } - - # if this is a 'bad spotter' user then ignore it - my $nossid = $_[6]; - $nossid =~ s/-\d+$//; - if ($badspotter->in($nossid)) { - dbg("PCPROT: Bad Spotter, dropped") if isdbg('chanerr'); - return; - } - - # convert the date to a unix date - my $d = cltounix($_[3], $_[4]); - # bang out (and don't pass on) if date is invalid or the spot is too old (or too young) - if (!$d || ($pcno == 11 && ($d < $main::systime - $pc11_max_age || $d > $main::systime + 900))) { - dbg("PCPROT: Spot ignored, invalid date or out of range ($_[3] $_[4])\n") if isdbg('chanerr'); - return; - } - - # is it 'baddx' - if ($baddx->in($_[2]) || BadWords::check($_[2]) || $_[2] =~ /COCK/) { - dbg("PCPROT: Bad DX spot, ignored") if isdbg('chanerr'); - return; - } - - # do some de-duping - $_[5] =~ s/^\s+//; # take any leading blanks off - $_[2] = unpad($_[2]); # take off leading and trailing blanks from spotted callsign - if ($_[2] =~ /BUST\w*$/) { - dbg("PCPROT: useless 'BUSTED' spot") if isdbg('chanerr'); - return; - } - if ($censorpc) { - my @bad; - if (@bad = BadWords::check($_[5])) { - dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chanerr'); - return; - } - } - - - my @spot = Spot::prepare($_[1], $_[2], $d, $_[5], $_[6], $_[7]); - # global spot filtering on INPUT - if ($self->{inspotsfilter}) { - my ($filter, $hops) = $self->{inspotsfilter}->it(@spot); - unless ($filter) { - dbg("PCPROT: Rejected by input spot filter") if isdbg('chanerr'); - return; - } - } - - # this goes after the input filtering, but before the add - # so that if it is input filtered, it isn't added to the dup - # list. This allows it to come in from a "legitimate" source - if (Spot::dup($_[1], $_[2], $d, $_[5], $_[6])) { - dbg("PCPROT: Duplicate Spot ignored\n") if isdbg('chanerr'); - return; - } - - # add it - Spot::add(@spot); - - # - # @spot at this point contains:- - # freq, spotted call, time, text, spotter, spotted cc, spotters cc, orig node - # then spotted itu, spotted cq, spotters itu, spotters cq - # you should be able to route on any of these - # - - # fix up qra locators of known users - my $user = DXUser->get_current($spot[4]); - if ($user) { - my $qra = $user->qra; - unless ($qra && is_qra($qra)) { - my $lat = $user->lat; - my $long = $user->long; - if (defined $lat && defined $long) { - $user->qra(DXBearing::lltoqra($lat, $long)); - $user->put; - } - } - - # send a remote command to a distant cluster if it is visible and there is no - # qra locator and we havn't done it for a month. - - unless ($user->qra) { - my $node; - my $to = $user->homenode; - my $last = $user->lastoper || 0; - if ($send_opernam && $to && $to ne $main::mycall && $main::systime > $last + $DXUser::lastoperinterval && ($node = Route::Node::get($to)) ) { - my $cmd = "forward/opernam $spot[4]"; - # send the rcmd but we aren't interested in the replies... - my $dxchan = $node->dxchan; - if ($dxchan && $dxchan->is_clx) { - route(undef, $to, pc84($main::mycall, $to, $main::mycall, $cmd)); - } else { - route(undef, $to, pc34($main::mycall, $to, $cmd)); - } - if ($to ne $_[7]) { - $to = $_[7]; - $node = Route::Node::get($to); - if ($node) { - $dxchan = $node->dxchan; - if ($dxchan && $dxchan->is_clx) { - route(undef, $to, pc84($main::mycall, $to, $main::mycall, $cmd)); - } else { - route(undef, $to, pc34($main::mycall, $to, $cmd)); - } - } - } - $user->lastoper($main::systime); - $user->put; - } - } - } - - # local processing - my $r; - eval { - $r = Local::spot($self, @spot); - }; - # dbg("Local::spot1 error $@") if isdbg('local') if $@; - return if $r; - - # DON'T be silly and send on PC26s! - return if $pcno == 26; - - # send out the filtered spots - send_dx_spot($self, $line, @spot) if @spot; -} - -# announces -sub handle_12 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - # return if $rspfcheck and !$self->rspfcheck(1, $_[5], $_[1]); - - # announce duplicate checking - $_[3] =~ s/^\s+//; # remove leading blanks - - if ($censorpc) { - my @bad; - if (@bad = BadWords::check($_[3])) { - dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chanerr'); - return; - } - } - - # if this is a 'nodx' node then ignore it - if ($badnode->in($_[5])) { - dbg("PCPROT: Bad Node, dropped") if isdbg('chanerr'); - return; - } - - # if this is a 'bad spotter' user then ignore it - my $nossid = $_[1]; - $nossid =~ s/-\d+$//; - if ($badspotter->in($nossid)) { - dbg("PCPROT: Bad Spotter, dropped") if isdbg('chanerr'); - return; - } - - my $dxchan; - - if ((($dxchan = DXChannel->get($_[2])) && $dxchan->is_user) || $_[4] =~ /^[\#\w.]+$/){ - $self->send_chat($line, @_[1..6]); - } elsif ($_[2] eq '*' || $_[2] eq $main::mycall) { - - # ignore something that looks like a chat line coming in with sysop - # flag - this is a kludge... - if ($_[3] =~ /^\#\d+ / && $_[4] eq '*') { - dbg('PCPROT: Probable chat rewrite, dropped') if isdbg('chanerr'); - return; - } - - # here's a bit of fun, convert incoming ann with a callsign in the first word - # or one saying 'to ' to a talk if we can route to the recipient - if ($ann_to_talk) { - my $call = AnnTalk::is_talk_candidate($_[1], $_[3]); - if ($call) { - my $ref = Route::get($call); - if ($ref) { - $dxchan = $ref->dxchan; - $dxchan->talk($_[1], $call, undef, $_[3], $_[5]) if $dxchan != $self; - return; - } - } - } - - # send it - $self->send_announce($line, @_[1..6]); - } else { - $self->route($_[2], $line); - } -} - -# incoming user -sub handle_16 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - if (eph_dup($line)) { - dbg("PCPROT: dup PC16 detected") if isdbg('chanerr'); - return; - } - - # general checks - my $dxchan; - my $ncall = $_[1]; - my $newline = "PC16^"; - - # do I want users from this channel? - unless ($self->user->wantpc16) { - dbg("PCPROT: don't send users to $self->{call}") if isdbg('chanerr'); - return; - } - # is it me? - if ($ncall eq $main::mycall) { - dbg("PCPROT: trying to alter config on this node from outside!") if isdbg('chanerr'); - return; - } - my $parent = Route::Node::get($ncall); - - # if there is a parent, proceed, otherwise if there is a latent PC19 in the PC19list, - # fix it up in the routing tables and issue it forth before the PC16 - unless ($parent) { - my $nl = $pc19list{$ncall}; - - if ($nl && @_ > 3) { # 3 because of the hop count! - - # this is a new (remembered) node, now attach it to me if it isn't in filtered - # and we haven't disallowed it - my $user = DXUser->get_current($ncall); - if (!$user) { - $user = DXUser->new($ncall); - $user->sort('A'); - $user->priv(1); # I have relented and defaulted nodes - $user->lockout(1); - $user->homenode($ncall); - $user->node($ncall); - } - - my $wantpc19 = $user->wantroutepc19; - if ($wantpc19 || !defined $wantpc19) { - my $new = Route->new($ncall); # throw away - if ($self->in_filter_route($new)) { - my @nrout; - for (@$nl) { - $parent = Route::Node::get($_->[0]); - $dxchan = $parent->dxchan if $parent; - if ($dxchan && $dxchan ne $self) { - dbg("PCPROT: PC19 from $self->{call} trying to alter locally connected $ncall, ignored!") if isdbg('chanerr'); - $parent = undef; - } - if ($parent) { - my $r = $parent->add($ncall, $_->[1], $_->[2]); - push @nrout, $r unless @nrout; - } - } - $user->wantroutepc19(1) unless defined $wantpc19; # for now we work on the basis that pc16 = real route - $user->lastin($main::systime) unless DXChannel->get($ncall); - $user->put; - - # route the pc19 - this will cause 'stuttering PC19s' for a while - $self->route_pc19($origin, $line, @nrout) if @nrout ; - $parent = Route::Node::get($ncall); - unless ($parent) { - dbg("PCPROT: lost $ncall after sending PC19 for it?"); - return; - } - } else { - return; - } - delete $pc19list{$ncall}; - } - } else { - dbg("PCPROT: Node $ncall not in config") if isdbg('chanerr'); - return; - } - } else { - - $dxchan = $parent->dxchan; - if ($dxchan && $dxchan ne $self) { - dbg("PCPROT: PC16 from $self->{call} trying to alter locally connected $ncall, ignored!") if isdbg('chanerr'); - return; - } - - # input filter if required - return unless $self->in_filter_route($parent); - } - - my $i; - my @rout; - for ($i = 2; $i < $#_; $i++) { - my ($call, $conf, $here) = $_[$i] =~ /^(\S+) (\S) (\d)/o; - next unless $call && $conf && defined $here && is_callsign($call); - next if $call eq $main::mycall; - - eph_del_regex("^PC17\\^$call\\^$ncall"); - - $conf = $conf eq '*'; - - # reject this if we think it is a node already - my $r = Route::Node::get($call); - my $u = DXUser->get_current($call) unless $r; - if ($r || ($u && $u->is_node)) { - dbg("PCPROT: $call is a node") if isdbg('chanerr'); - next; - } - - $r = Route::User::get($call); - my $flags = Route::here($here)|Route::conf($conf); - - if ($r) { - my $au = $r->addparent($parent); - if ($r->flags != $flags) { - $r->flags($flags); - $au = $r; - } - push @rout, $r if $au; - } else { - push @rout, $parent->add_user($call, $flags); - } - - - # add this station to the user database, if required - $call =~ s/-\d+$//o; # remove ssid for users - my $user = DXUser->get_current($call); - $user = DXUser->new($call) if !$user; - $user->homenode($parent->call) if !$user->homenode; - $user->node($parent->call); - $user->lastin($main::systime) unless DXChannel->get($call); - $user->put; - } - $self->route_pc16($origin, $line, $parent, @rout) if @rout; -} - -# remove a user -sub handle_17 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - my $dxchan; - my $ncall = $_[2]; - my $ucall = $_[1]; - - eph_del_regex("^PC16\\^$ncall.*$ucall"); - - # do I want users from this channel? - unless ($self->user->wantpc16) { - dbg("PCPROT: don't send users to $self->{call}") if isdbg('chanerr'); - return; - } - if ($ncall eq $main::mycall) { - dbg("PCPROT: trying to alter config on this node from outside!") if isdbg('chanerr'); - return; - } - - my $uref = Route::User::get($ucall); - unless ($uref) { - dbg("PCPROT: Route::User $ucall not in config") if isdbg('chanerr'); - return; - } - my $parent = Route::Node::get($ncall); - unless ($parent) { - dbg("PCPROT: Route::Node $ncall not in config") if isdbg('chanerr'); - return; - } - - $dxchan = $parent->dxchan; - if ($dxchan && $dxchan ne $self) { - dbg("PCPROT: PC17 from $self->{call} trying to alter locally connected $ncall, ignored!") if isdbg('chanerr'); - return; - } - - # input filter if required - return unless $self->in_filter_route($parent); - - $parent->del_user($uref); - - if (eph_dup($line)) { - dbg("PCPROT: dup PC17 detected") if isdbg('chanerr'); - return; - } - - $self->route_pc17($origin, $line, $parent, $uref); -} - -# link request -sub handle_18 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - $self->state('init'); - - # record the type and version offered - if ($_[1] =~ /DXSpider Version: (\d+\.\d+) Build: (\d+\.\d+)/) { - $self->version(53 + $1); - $self->user->version(53 + $1); - $self->build(0 + $2); - $self->user->build(0 + $2); - unless ($self->is_spider) { - $self->user->sort('S'); - $self->user->put; - $self->sort('S'); - } - } else { - $self->version(50.0); - $self->version($_[2] / 100) if $_[2] && $_[2] =~ /^\d+$/; - $self->user->version($self->version); - } - - # first clear out any nodes on this dxchannel - my $parent = Route::Node::get($self->{call}); - my @rout = $parent->del_nodes; - $self->route_pc21($origin, $line, @rout, $parent) if @rout; - $self->send_local_config(); - $self->send(pc20()); -} - -# incoming cluster list -sub handle_19 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - my $i; - my $newline = "PC19^"; - - if (eph_dup($line)) { - dbg("PCPROT: dup PC19 detected") if isdbg('chanerr'); - return; - } - - # new routing list - my @rout; - - # first get the INTERFACE node - my $parent = Route::Node::get($self->{call}); - unless ($parent) { - dbg("DXPROT: my parent $self->{call} has disappeared"); - $self->disconnect; - return; - } - - # if the origin isn't the same as the INTERFACE, then reparent, creating nodes as necessary - if ($origin ne $self->call) { - my $op = Route::Node::get($origin); - unless ($op) { - $op = $parent->add($origin, 5000, Route::here(1)); - my $user = DXUser->get_current($origin); - if (!$user) { - $user = DXUser->new($origin); - $user->sort('S'); - $user->priv(1); # I have relented and defaulted nodes - $user->lockout(1); - $user->homenode($origin); - $user->node($origin); - $user->wantroutepc19(1); - $user->wantpc90(1); - } - $user->put; - } - $parent = $op; - } - - # parse the PC19 - for ($i = 1; $i < $#_-1; $i += 4) { - my $here = $_[$i]; - my $call = uc $_[$i+1]; - my $conf = $_[$i+2]; - my $ver = $_[$i+3]; - next unless defined $here && defined $conf && is_callsign($call); - - eph_del_regex("^PC(?:21\\^$call|17\\^[^\\^]+\\^$call)"); - - # check for sane parameters - # $ver = 5000 if $ver eq '0000'; - next if $ver < 5000; # only works with version 5 software - next if length $call < 3; # min 3 letter callsigns - next if $call eq $main::mycall; - - # check that this PC19 isn't trying to alter the wrong dxchan - my $dxchan = DXChannel->get($call); - if ($dxchan && $dxchan != $self) { - dbg("PCPROT: PC19 from $self->{call} trying to alter wrong locally connected $call, ignored!") if isdbg('chanerr'); - next; - } - - # add this station to the user database, if required (don't remove SSID from nodes) - my $user = DXUser->get_current($call); - if (!$user) { - $user = DXUser->new($call); - $user->sort('A'); - $user->priv(1); # I have relented and defaulted nodes - $user->lockout(1); - $user->homenode($call); - $user->node($call); - } - - my $r = Route::Node::get($call); - my $flags = Route::here($here)|Route::conf($conf); - - # modify the routing table if it is in it, otherwise store it in the pc19list for now - if ($r) { - my $ar; - if ($call ne $parent->call) { - if ($self->in_filter_route($r)) { - $ar = $parent->add($call, $ver, $flags); - push @rout, $ar if $ar; - } else { - next; - } - } - if ($r->version ne $ver || $r->flags != $flags) { - $r->version($ver); - $r->flags($flags); - push @rout, $r unless $ar; - } - } else { - - # if he is directly connected or allowed then add him, otherwise store him up for later - if ($call eq $self->{call} || $user->wantroutepc19) { - my $new = Route->new($call); # throw away - if ($self->in_filter_route($new)) { - my $ar = $parent->add($call, $ver, $flags); - $user->wantroutepc19(1) unless defined $user->wantroutepc19; - push @rout, $ar if $ar; - } else { - next; - } - } else { - $pc19list{$call} = [] unless exists $pc19list{$call}; - my $nl = $pc19list{$call}; - push @{$pc19list{$call}}, [$self->{call}, $ver, $flags] unless grep $_->[0] eq $self->{call}, @$nl; - } - } - - # unbusy and stop and outgoing mail (ie if somehow we receive another PC19 without a disconnect) - my $mref = DXMsg::get_busy($call); - $mref->stop_msg($call) if $mref; - - $user->lastin($main::systime) unless DXChannel->get($call); - $user->put; - } - - - $self->route_pc19($origin, $line, @rout) if @rout; -} - -# send local configuration -sub handle_20 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - $self->send_local_config(); - $self->send(pc22()); - $self->state('normal'); - $self->{lastping} = 0; -} - -# delete a cluster from the list -sub handle_21 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - my $call = uc $_[1]; - - eph_del_regex("^PC1[679].*$call"); - - # if I get a PC21 from the same callsign as self then treat it - # as a PC39: I have gone away - if ($call eq $self->call) { - $self->disconnect(1); - return; - } - - # check to see if we are in the pc19list, if we are then don't bother with any of - # this routing table manipulation, just remove it from the list and dump it - my @rout; - if (my $nl = $pc19list{$call}) { - $pc19list{$call} = [ grep {$_->[0] ne $self->{call}} @$nl ]; - delete $pc19list{$call} unless @{$pc19list{$call}}; - } else { - - my $parent = Route::Node::get($self->{call}); - unless ($parent) { - dbg("DXPROT: my parent $self->{call} has disappeared"); - $self->disconnect; - return; - } - if ($call ne $main::mycall) { # don't allow malicious buggers to disconnect me! - my $node = Route::Node::get($call); - if ($node) { - - my $dxchan = DXChannel->get($call); - if ($dxchan && $dxchan != $self) { - dbg("PCPROT: PC21 from $self->{call} trying to alter locally connected $call, ignored!") if isdbg('chanerr'); - return; - } - - # input filter it - return unless $self->in_filter_route($node); - - # routing objects - push @rout, $node->del($parent); - } - } else { - dbg("PCPROT: I WILL _NOT_ be disconnected!") if isdbg('chanerr'); - return; - } - } - - $self->route_pc21($origin, $line, @rout) if @rout; -} - - -sub handle_22 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - $self->state('normal'); - $self->{lastping} = 0; -} - -# WWV info -sub handle_23 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - # route foreign' pc27s - if ($pcno == 27) { - if ($_[8] ne $main::mycall) { - $self->route($_[8], $line); - return; - } - } - - return if $rspfcheck and !$self->rspfcheck(1, $_[8], $_[7]); - - # do some de-duping - my $d = cltounix($_[1], sprintf("%02d18Z", $_[2])); - my $sfi = unpad($_[3]); - my $k = unpad($_[4]); - my $i = unpad($_[5]); - my ($r) = $_[6] =~ /R=(\d+)/; - $r = 0 unless $r; - if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $_[2] < 0 || $_[2] > 23) { - dbg("PCPROT: WWV Date ($_[1] $_[2]) out of range") if isdbg('chanerr'); - return; - } - if (Geomag::dup($d,$sfi,$k,$i,$_[6])) { - dbg("PCPROT: Dup WWV Spot ignored\n") if isdbg('chanerr'); - return; - } - $_[7] =~ s/-\d+$//o; # remove spotter's ssid - - my $wwv = Geomag::update($d, $_[2], $sfi, $k, $i, @_[6..8], $r); - - my $rep; - eval { - $rep = Local::wwv($self, $_[1], $_[2], $sfi, $k, $i, @_[6..8], $r); - }; - # dbg("Local::wwv2 error $@") if isdbg('local') if $@; - return if $rep; - - # DON'T be silly and send on PC27s! - return if $pcno == 27; - - # broadcast to the eager world - send_wwv_spot($self, $line, $d, $_[2], $sfi, $k, $i, @_[6..8]); -} - -# set here status -sub handle_24 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - my $call = uc $_[1]; - my ($nref, $uref); - $nref = Route::Node::get($call); - $uref = Route::User::get($call); - return unless $nref || $uref; # if we don't know where they are, it's pointless sending it on - - if (eph_dup($line)) { - dbg("PCPROT: Dup PC24 ignored\n") if isdbg('chanerr'); - return; - } - - $nref->here($_[2]) if $nref; - $uref->here($_[2]) if $uref; - my $ref = $nref || $uref; - return unless $self->in_filter_route($ref); - - $self->route_pc24($origin, $line, $ref, $_[3]); -} - -# merge request -sub handle_25 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - if ($_[1] ne $main::mycall) { - $self->route($_[1], $line); - return; - } - if ($_[2] eq $main::mycall) { - dbg("PCPROT: Trying to merge to myself, ignored") if isdbg('chanerr'); - return; - } - - Log('DXProt', "Merge request for $_[3] spots and $_[4] WWV from $_[2]"); - - # spots - if ($_[3] > 0) { - my @in = reverse Spot::search(1, undef, undef, 0, $_[3]); - my $in; - foreach $in (@in) { - $self->send(pc26(@{$in}[0..4], $_[2])); - } - } - - # wwv - if ($_[4] > 0) { - my @in = reverse Geomag::search(0, $_[4], time, 1); - my $in; - foreach $in (@in) { - $self->send(pc27(@{$in}[0..5], $_[2])); - } - } -} - -sub handle_26 {goto &handle_11} -sub handle_27 {goto &handle_23} - -# mail/file handling -sub handle_28 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - if ($_[1] eq $main::mycall) { - no strict 'refs'; - my $sub = "DXMsg::handle_$pcno"; - &$sub($self, @_); - } else { - $self->route($_[1], $line) unless $self->is_clx; - } -} - -sub handle_29 {goto &handle_28} -sub handle_30 {goto &handle_28} -sub handle_31 {goto &handle_28} -sub handle_32 {goto &handle_28} -sub handle_33 {goto &handle_28} - -sub handle_34 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - if (eph_dup($line, $eph_pc34_restime)) { - dbg("PCPROT: dupe PC34, ignored") if isdbg('chanerr'); - } else { - $self->process_rcmd($_[1], $_[2], $_[2], $_[3]); - } -} - -# remote command replies -sub handle_35 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - eph_del_regex("^PC35\\^$_[2]\\^$_[1]\\^"); - $self->process_rcmd_reply($_[1], $_[2], $_[1], $_[3]); -} - -sub handle_36 {goto &handle_34} - -# database stuff -sub handle_37 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - DXDb::process($self, $line); -} - -# node connected list from neighbour -sub handle_38 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; -} - -# incoming disconnect -sub handle_39 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - if ($_[1] eq $self->{call}) { - $self->disconnect(1); - } else { - dbg("PCPROT: came in on wrong channel") if isdbg('chanerr'); - } -} - -sub handle_40 {goto &handle_28} - -# user info -sub handle_41 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - my $call = $_[1]; - - my $l = $line; - $l =~ s/[\x00-\x20\x7f-\xff]+//g; # remove all funny characters and spaces for dup checking - if (eph_dup($l, $eph_info_restime)) { - dbg("PCPROT: dup PC41, ignored") if isdbg('chanerr'); - return; - } - - # input filter if required - # my $ref = Route::get($call) || Route->new($call); - # return unless $self->in_filter_route($ref); - - if ($_[3] eq $_[2] || $_[3] =~ /^\s*$/) { - dbg('PCPROT: invalid value') if isdbg('chanerr'); - return; - } - - # add this station to the user database, if required - my $user = DXUser->get_current($call); - $user = DXUser->new($call) unless $user; - - if ($_[2] == 1) { - $user->name($_[3]); - } elsif ($_[2] == 2) { - $user->qth($_[3]); - } elsif ($_[2] == 3) { - if (is_latlong($_[3])) { - my ($lat, $long) = DXBearing::stoll($_[3]); - $user->lat($lat); - $user->long($long); - $user->qra(DXBearing::lltoqra($lat, $long)); - } else { - dbg('PCPROT: not a valid lat/long') if isdbg('chanerr'); - return; - } - } elsif ($_[2] == 4) { - $user->homenode($_[3]); - } elsif ($_[2] == 5) { - if (is_qra(uc $_[3])) { - my ($lat, $long) = DXBearing::qratoll(uc $_[3]); - $user->lat($lat); - $user->long($long); - $user->qra(uc $_[3]); - } else { - dbg('PCPROT: not a valid QRA locator') if isdbg('chanerr'); - return; - } - } - $user->lastoper($main::systime); # to cut down on excessive for/opers being generated - $user->put; - - unless ($self->{isolate}) { - DXChannel::broadcast_nodes($line, $self); # send it to everyone but me - } - - # perhaps this IS what we want after all - # $self->route_pc41($ref, $call, $_[2], $_[3], $_[4]); -} - -sub handle_42 {goto &handle_28} - - -# database -sub handle_44 {goto &handle_37} -sub handle_45 {goto &handle_37} -sub handle_46 {goto &handle_37} -sub handle_47 {goto &handle_37} -sub handle_48 {goto &handle_37} - -# message and database -sub handle_49 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; + my $self = DXChannel::alloc(@_); - if (eph_dup($line)) { - dbg("PCPROT: Dup PC49 ignored\n") if isdbg('chanerr'); - return; - } - - if ($_[1] eq $main::mycall) { - DXMsg::handle_49($self, @_); - } else { - $self->route($_[1], $line) unless $self->is_clx; - } + # add this node to the table, the values get filled in later + my $pkg = shift; + my $call = shift; + + my $uref = Route::Node::get($call) || Route::Node->new($call); + $uref->here(1); + $uref->conf(0); + $uref->version($pc19_version); + $main::routeroot->link_node($uref, $self); + return $self; } -# keep alive/user list -sub handle_50 +# this is how a pc connection starts (for an incoming connection) +# issue a PC38 followed by a PC18, then wait for a PC20 (remembering +# all the crap that comes between). +sub start { - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; + my ($self, $line, $sort) = @_; + my $call = $self->{call}; + my $user = $self->{user}; - my $call = $_[1]; - my $node = Route::Node::get($call); - if ($node) { - return unless $node->call eq $self->{call}; - $node->usercount($_[2]); + # log it + my $host = $self->{conn}->{peerhost} || "unknown"; + Log('DXProt', "$call connected from $host"); + + # remember type of connection + $self->{consort} = $line; + $self->{outbound} = $sort eq 'O'; + my $priv = $user->priv; + $priv = $user->priv(1) unless $priv; + $self->{priv} = $priv; # other clusters can always be 'normal' users + $self->{lang} = $user->lang || 'en'; + $self->{isolate} = $user->{isolate}; + $self->{consort} = $line; # save the connection type + $self->{here} = 1; + $self->{width} = 80; - # input filter if required - return unless $self->in_filter_route($node); + # sort out registration + $self->{registered} = 1; - $self->route_pc50($origin, $line, $node, $_[2], $_[3]) unless eph_dup($line); - } -} - -# incoming ping requests/answers -sub handle_51 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - my $to = $_[1]; - my $from = $_[2]; - my $flag = $_[3]; + # get the output filters + $self->{spotsfilter} = Filter::read_in('spots', $call, 0) || Filter::read_in('spots', 'node_default', 0); + $self->{wwvfilter} = Filter::read_in('wwv', $call, 0) || Filter::read_in('wwv', 'node_default', 0); + $self->{wcyfilter} = Filter::read_in('wcy', $call, 0) || Filter::read_in('wcy', 'node_default', 0); + $self->{annfilter} = Filter::read_in('ann', $call, 0) || Filter::read_in('ann', 'node_default', 0) ; + $self->{routefilter} = Filter::read_in('route', $call, 0) || Filter::read_in('route', 'node_default', 0) unless $self->{isolate} ; - - # is it for us? - if ($to eq $main::mycall) { - if ($flag == 1) { - $self->send(pc51($from, $to, '0')); - } else { - # it's a reply, look in the ping list for this one - my $ref = $pings{$from}; - if ($ref) { - my $tochan = DXChannel->get($from); - while (@$ref) { - my $r = shift @$ref; - my $dxchan = DXChannel->get($r->{call}); - next unless $dxchan; - my $t = tv_interval($r->{t}, [ gettimeofday ]); - if ($dxchan->is_user) { - my $s = sprintf "%.2f", $t; - my $ave = sprintf "%.2f", $tochan ? ($tochan->{pingave} || $t) : $t; - $dxchan->send($dxchan->msg('pingi', $from, $s, $ave)) - } elsif ($dxchan->is_node) { - if ($tochan) { - my $nopings = $tochan->user->nopings || $obscount; - push @{$tochan->{pingtime}}, $t; - shift @{$tochan->{pingtime}} if @{$tochan->{pingtime}} > 6; - - # cope with a missed ping, this means you must set the pingint large enough - if ($t > $tochan->{pingint} && $t < 2 * $tochan->{pingint} ) { - $t -= $tochan->{pingint}; - } - - # calc smoothed RTT a la TCP - if (@{$tochan->{pingtime}} == 1) { - $tochan->{pingave} = $t; - } else { - $tochan->{pingave} = $tochan->{pingave} + (($t - $tochan->{pingave}) / 6); - } - $tochan->{nopings} = $nopings; # pump up the timer - } - } - } - } - } - } else { - if ($line !~ /^PC90/ && eph_dup($line)) { - dbg("PCPROT: dup PC51 detected") if isdbg('chanerr'); - return; - } - # route down an appropriate thingy - $self->route($to, $line); - } -} -# dunno but route it -sub handle_75 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - my $call = $_[1]; - if ($call ne $main::mycall) { - $self->route($call, $line); - } -} + # get the INPUT filters (these only pertain to Clusters) + $self->{inspotsfilter} = Filter::read_in('spots', $call, 1) || Filter::read_in('spots', 'node_default', 1); + $self->{inwwvfilter} = Filter::read_in('wwv', $call, 1) || Filter::read_in('wwv', 'node_default', 1); + $self->{inwcyfilter} = Filter::read_in('wcy', $call, 1) || Filter::read_in('wcy', 'node_default', 1); + $self->{inannfilter} = Filter::read_in('ann', $call, 1) || Filter::read_in('ann', 'node_default', 1); + $self->{inroutefilter} = Filter::read_in('route', $call, 1) || Filter::read_in('route', 'node_default', 1) unless $self->{isolate}; + + # set unbuffered and no echo + $self->send_now('B',"0"); + $self->send_now('E',"0"); + $self->conn->echo(0) if $self->conn->can('echo'); + + # ping neighbour node stuff + my $ping = $user->pingint; + $ping = $pingint unless defined $ping; + $self->{pingint} = $ping; + $self->{nopings} = $user->nopings || $obscount; + $self->{pingtime} = [ ]; + $self->{pingave} = 999; + $self->{metric} ||= 100; + $self->{lastping} = $main::systime; -# WCY broadcasts -sub handle_73 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - my $call = $_[1]; - - # do some de-duping - my $d = cltounix($call, sprintf("%02d18Z", $_[2])); - if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $_[2] < 0 || $_[2] > 23) { - dbg("PCPROT: WCY Date ($call $_[2]) out of range") if isdbg('chanerr'); - return; - } - @_ = map { unpad($_) } @_; - if (WCY::dup($d)) { - dbg("PCPROT: Dup WCY Spot ignored\n") if isdbg('chanerr'); - return; + # send initialisation string + unless ($self->{outbound}) { + $self->sendinit; } - - my $wcy = WCY::update($d, @_[2..12]); + + $self->state('init'); + $self->{pc50_t} = $main::systime; - my $rep; - eval { - $rep = Local::wcy($self, @_[1..12]); - }; - # dbg("Local::wcy error $@") if isdbg('local') if $@; - return if $rep; + # send info to all logged in thingies + $self->tell_login('loginn'); - # broadcast to the eager world - send_wcy_spot($self, $line, $d, @_[2..12]); + # run a script send the output to the debug file + my $script = new Script(lc $call) || new Script('node_default'); + $script->run($self) if $script; } -# remote commands (incoming) -sub handle_84 +# +# send outgoing 'challenge' +# + +sub sendinit { my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - $self->process_rcmd($_[1], $_[2], $_[3], $_[4]); + $self->send(pc18()); } -# remote command replies -sub handle_85 +sub removepc90 { - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - $self->process_rcmd_reply($_[1], $_[2], $_[3], $_[4]); + $_[0] =~ s/^PC90\^[-A-Z0-9]+\^\d+\^//; + $_[0] =~ s/^PC91\^[-A-Z0-9]+\^\d+\^[-A-Z0-9]+\^//; } -# if get here then rebroadcast the thing with its Hop count decremented (if -# there is one). If it has a hop count and it decrements to zero then don't -# rebroadcast it. +#sub send +#{ +# my $self = shift; +# while (@_) { +# my $line = shift; +# $self->SUPER::send($line); +# } +#} + # -# NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be -# REBROADCAST!!!! +# This is the normal pcxx despatcher # - -sub handle_default +sub normal { - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; + my ($self, $line) = @_; + + # remove any incoming PC90 frames + removepc90($line); + + my @field = split /\^/, $line; + return unless @field; + + pop @field if $field[-1] eq '~'; + +# print join(',', @field), "\n"; + + + # process PC frames, this will fail unless the frame starts PCnn + my ($pcno) = $field[0] =~ /^PC(\d\d)/; # just get the number + unless (defined $pcno && $pcno >= 10 && $pcno <= 99) { + dbg("PCPROT: unknown protocol") if isdbg('chanerr'); + return; + } + + # check for and dump bad protocol messages + my $n = check($pcno, @field); + if ($n) { + dbg("PCPROT: bad field $n, dumped (" . parray($checklist[$pcno-10]) . ")") if isdbg('chanerr'); + return; + } + + my $origin = $self->{call}; + no strict 'subs'; + my $sub = "handle_$pcno"; - if (eph_dup($line)) { - dbg("PCPROT: Ephemeral dup, dropped") if isdbg('chanerr'); + if ($self->can($sub)) { + $self->$sub($pcno, $line, $origin, @field); } else { - unless ($self->{isolate}) { - DXChannel::broadcast_nodes($line, $self) if $line =~ /\^H\d+\^?~?$/; # send it to everyone but me - } + $self->handle_default($pcno, $line, $origin, @field); } } + # # This is called from inside the main cluster processing loop and is used # for despatching commands that are doing some long processing job # +# It is called once per second +# sub process { my $t = time; @@ -1709,6 +421,8 @@ sub process } } + Investigate::process(); + # every ten seconds if ($t - $last10 >= 10) { # clean out ephemera @@ -1724,8 +438,111 @@ sub process } # -# finish up a pc context +# This the routine that does all routing table updates +# It determines which nodes have been created or +# deleted. +# +# legacy protocol calls this routine after transforming +# the arguments to be compatible, viz: some scalar +# parameters and a bunch of routing objects. # +# A list of 4 references to (any) adds/deletes that +# have occured is returned to allow generation of +# PC1[679] and PC21 +# + +sub process_pc59 +{ + my $self = shift; + my $pcno = shift; + my $sort = shift; + my $hexstamp = shift || hexstamp(); + my $node = shift; + my $enode = shift; + my $line = shift; + + my $ncall = $node->call; + my $origin = $enode->call; + + # if it is a delete, disconnect all the entries mentioned + # from this node (which is a parent in this context). + my @delnode; + my @deluser; + if ($sort eq 'D') { + for my $ref (@_) { + next if $ref->call eq $ncall; + next if $ref->call eq $main::mycall; + if ($ref->isa('Route::Node')) { + push @delnode, $enode->unlink_node($ref, $self); + } elsif ($ref->isa('Route::User')) { + push @deluser, $enode->del_user($ref); + } + } + } + + # if it is an add, connect all the entries + my @addnode; + my @adduser; + if ($sort eq 'A') { + for my $ref (@_) { + next if $ref->call eq $ncall; + next if $ref->call eq $main::mycall; + if ($ref->isa('Route::Node')) { + my $new = $enode->link_node($ref, $self); + push @addnode, $new if $new; + } elsif ($ref->isa('Route::User')) { + push @adduser, $enode->add_user($ref); + } + } + } + + # if it is a configure, unlink all the nodes and users that + # are not in @_ but are in the node, then add all the + # nodes and users that are @_ but not in the node. + # + if ($sort eq 'C') { + my @dn; + my @du; + my @an; + my @au; + for my $r (map {Route::Node::get($_)} $node->nodes) { + next unless $r; + next if $r->call eq $ncall; + next if $r->call eq $main::mycall; + push @dn, $r unless grep $_->call eq $r->call, @_; + } + for my $r (map {Route::User::get($_)} $node->users) { + next unless $r; + push @du, $r unless grep $_->call eq $r->call, @_; + } + for my $r (@_) { + next unless $r; + next if $r->call eq $ncall; + next if $r->call eq $main::mycall; + if ($r->isa('Route::Node')) { + push @an, $r unless grep $r->call eq $_, $node->nodes; + } elsif ($r->isa('Route::User')) { + push @au, $r unless grep $r->call eq $_, $node->users; + } + } + push @addnode, $node if $self->{state} =~ /^init/; + push @delnode, $enode->remove_route($_, $self) for @dn; + push @deluser, $enode->del_user($_) for @du; + push @addnode, $enode->add_route($_, $self) for @an; + push @adduser, $enode->add_user($_) for @au; + } + + $self->route_pc21($origin, $line, @delnode) if @delnode; + $self->route_pc19($origin, $line, @addnode) if @addnode; + $self->route_pc17($origin, $line, $enode, @deluser) if @deluser; + $self->route_pc16($origin, $line, $enode, @adduser) if @adduser; + + unshift @_, $enode if $ncall ne $origin; + $self->route_pc59($origin, $line, $sort, $hexstamp, $origin, @_) if @_; + + $_->delete for @deluser; + $_->delete for @delnode; +} # # some active measures @@ -1789,20 +606,8 @@ sub send_wwv_spot my $line = shift; my @dxchan = DXChannel->get_all(); my $dxchan; - my ($wwv_dxcc, $wwv_itu, $wwv_cq, $org_dxcc, $org_itu, $org_cq) = (0..0); - my @dxcc = Prefix::extract($_[6]); - if (@dxcc > 0) { - $wwv_dxcc = $dxcc[1]->dxcc; - $wwv_itu = $dxcc[1]->itu; - $wwv_cq = $dxcc[1]->cq; - } - @dxcc = Prefix::extract($_[7]); - if (@dxcc > 0) { - $org_dxcc = $dxcc[1]->dxcc; - $org_itu = $dxcc[1]->itu; - $org_cq = $dxcc[1]->cq; - } - + my @dxcc = ((Prefix::cty_data($_[6]))[0..2], (Prefix::cty_data($_[7]))[0..2]); + # send it if it isn't the except list and isn't isolated and still has a hop count # taking into account filtering and so on foreach $dxchan (@dxchan) { @@ -1811,7 +616,7 @@ sub send_wwv_spot my $routeit; my ($filter, $hops); - $dxchan->wwv($line, $self->{isolate}, @_, $self->{call}, $wwv_dxcc, $wwv_itu, $wwv_cq, $org_dxcc, $org_itu, $org_cq); + $dxchan->wwv($line, $self->{isolate}, @_, $self->{call}, @dxcc); } } @@ -1835,19 +640,7 @@ sub send_wcy_spot my $line = shift; my @dxchan = DXChannel->get_all(); my $dxchan; - my ($wcy_dxcc, $wcy_itu, $wcy_cq, $org_dxcc, $org_itu, $org_cq) = (0..0); - my @dxcc = Prefix::extract($_[10]); - if (@dxcc > 0) { - $wcy_dxcc = $dxcc[1]->dxcc; - $wcy_itu = $dxcc[1]->itu; - $wcy_cq = $dxcc[1]->cq; - } - @dxcc = Prefix::extract($_[11]); - if (@dxcc > 0) { - $org_dxcc = $dxcc[1]->dxcc; - $org_itu = $dxcc[1]->itu; - $org_cq = $dxcc[1]->cq; - } + my @dxcc = ((Prefix::cty_data($_[10]))[0..2], (Prefix::cty_data($_[11]))[0..2]); # send it if it isn't the except list and isn't isolated and still has a hop count # taking into account filtering and so on @@ -1855,7 +648,7 @@ sub send_wcy_spot next if $dxchan == $main::me; next if $dxchan == $self; - $dxchan->wcy($line, $self->{isolate}, @_, $self->{call}, $wcy_dxcc, $wcy_itu, $wcy_cq, $org_dxcc, $org_itu, $org_cq); + $dxchan->wcy($line, $self->{isolate}, @_, $self->{call}, @dxcc); } } @@ -1899,28 +692,13 @@ sub send_announce # obtain country codes etc - my ($ann_dxcc, $ann_itu, $ann_cq, $org_dxcc, $org_itu, $org_cq) = (0..0); - my ($ann_state, $org_state) = ("", ""); - my @dxcc = Prefix::extract($_[0]); - if (@dxcc > 0) { - $ann_dxcc = $dxcc[1]->dxcc; - $ann_itu = $dxcc[1]->itu; - $ann_cq = $dxcc[1]->cq; - $ann_state = $dxcc[1]->state; - } - @dxcc = Prefix::extract($_[4]); - if (@dxcc > 0) { - $org_dxcc = $dxcc[1]->dxcc; - $org_itu = $dxcc[1]->itu; - $org_cq = $dxcc[1]->cq; - $org_state = $dxcc[1]->state; - } - + my @a = Prefix::cty_data($_[0]); + my @b = Prefix::cty_data($_[4]); if ($self->{inannfilter}) { my ($filter, $hops) = $self->{inannfilter}->it(@_, $self->{call}, - $ann_dxcc, $ann_itu, $ann_cq, - $org_dxcc, $org_itu, $org_cq, $ann_state, $org_state); + @a[0..2], + @b[0..2], $a[3], $b[3]); unless ($filter) { dbg("PCPROT: Rejected by input announce filter") if isdbg('chanerr'); return; @@ -1939,7 +717,8 @@ sub send_announce foreach $dxchan (@dxchan) { next if $dxchan == $main::me; next if $dxchan == $self && $self->is_node; - $dxchan->announce($line, $self->{isolate}, $to, $target, $text, @_, $self->{call}, $ann_dxcc, $ann_itu, $ann_cq, $org_dxcc, $org_itu, $org_cq); + $dxchan->announce($line, $self->{isolate}, $to, $target, $text, @_, $self->{call}, + @a[0..2], @b[0..2]); } } @@ -1969,28 +748,13 @@ sub send_chat } # obtain country codes etc - my ($ann_dxcc, $ann_itu, $ann_cq, $org_dxcc, $org_itu, $org_cq) = (0..0); - my ($ann_state, $org_state) = ("", ""); - my @dxcc = Prefix::extract($_[0]); - if (@dxcc > 0) { - $ann_dxcc = $dxcc[1]->dxcc; - $ann_itu = $dxcc[1]->itu; - $ann_cq = $dxcc[1]->cq; - $ann_state = $dxcc[1]->state; - } - @dxcc = Prefix::extract($_[4]); - if (@dxcc > 0) { - $org_dxcc = $dxcc[1]->dxcc; - $org_itu = $dxcc[1]->itu; - $org_cq = $dxcc[1]->cq; - $org_state = $dxcc[1]->state; - } - + my @a = Prefix::cty_data($_[0]); + my @b = Prefix::cty_data($_[4]); if ($self->{inannfilter}) { my ($filter, $hops) = $self->{inannfilter}->it(@_, $self->{call}, - $ann_dxcc, $ann_itu, $ann_cq, - $org_dxcc, $org_itu, $org_cq, $ann_state, $org_state); + @a[0..2], + @b[0..2], $a[3], $b[3]); unless ($filter) { dbg("PCPROT: Rejected by input announce filter") if isdbg('chanerr'); return; @@ -2020,7 +784,8 @@ sub send_chat } } - $dxchan->chat($is_ak1a ? $ak1a_line : $line, $self->{isolate}, $target, $_[1], $text, @_, $self->{call}, $ann_dxcc, $ann_itu, $ann_cq, $org_dxcc, $org_itu, $org_cq); + $dxchan->chat($is_ak1a ? $ak1a_line : $line, $self->{isolate}, $target, $_[1], + $text, @_, $self->{call}, @a[0..2], @b[0..2]); } } @@ -2056,31 +821,29 @@ sub send_local_config my @remotenodes; dbg('DXProt::send_local_config') if isdbg('trace'); - - # send our nodes - if ($self->{isolate}) { - @localnodes = ( $main::routeroot ); - $self->send_route($main::mycall, \&pc19, 1, $main::routeroot); + + if ($self->{newroute}) { + my @nodes = $self->{isolate} ? ($main::routeroot) : grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} } DXChannel::get_all_nodes(); + my @users = DXChannel::get_all_users(); + @localnodes = map { Route::Node::get($_->{call}) } @nodes; + my @localusers = map { Route::User::get($_->{call}) } @users; + $self->send_route($main::mycall, \&pc59, @nodes+@users+4, 'C', 0, $main::mycall, $main::routeroot, @localnodes, @localusers); } else { - # create a list of all the nodes that are not connected to this connection - # and are not themselves isolated, this to make sure that isolated nodes - # don't appear outside of this node - - # send locally connected nodes - my @dxchan = grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} } DXChannel::get_all_nodes(); - @localnodes = map { my $r = Route::Node::get($_->{call}); $r ? $r : () } @dxchan if @dxchan; - $self->send_route($main::mycall, \&pc19, scalar(@localnodes)+1, $main::routeroot, @localnodes); - - my $node; - if ($self->user->wantpc90) { - for $node (@localnodes) { - my @nodes = map {my $r = Route::Node::get($_); $r ? $r : ()} $node->nodes; - $self->send_route($node->call, \&pc19, scalar(@nodes)+1, @nodes); - for my $r (@nodes) { - push @remotenodes, $r unless grep $r eq $_, @remotenodes; - } - } + # send our nodes + if ($self->{isolate}) { + @localnodes = ( $main::routeroot ); + $self->send_route($main::mycall, \&pc19, 1, $main::routeroot); } else { + # create a list of all the nodes that are not connected to this connection + # and are not themselves isolated, this to make sure that isolated nodes + # don't appear outside of this node + + # send locally connected nodes + my @dxchan = grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} } DXChannel::get_all_nodes(); + @localnodes = map { my $r = Route::Node::get($_->{call}); $r ? $r : () } @dxchan if @dxchan; + $self->send_route($main::mycall, \&pc19, scalar(@localnodes)+1, $main::routeroot, @localnodes); + + my $node; my @rawintcalls = map { $_->nodes } @localnodes if @localnodes; my @intcalls; for $node (@rawintcalls) { @@ -2093,17 +856,15 @@ sub send_local_config } $self->send_route($main::mycall, \&pc19, scalar(@remotenodes), @remotenodes); } - } - - - - # get all the users connected on the above nodes and send them out - foreach $node ($main::routeroot, @localnodes, @remotenodes) { - if ($node) { - my @rout = map {my $r = Route::User::get($_); $r ? ($r) : ()} $node->users; - $self->send_route($main::mycall, \&pc16, 1, $node, @rout) if @rout && $self->user->wantsendpc16; - } else { - dbg("sent a null value") if isdbg('chanerr'); + + # get all the users connected on the above nodes and send them out + foreach $node ($main::routeroot, @localnodes, @remotenodes) { + if ($node) { + my @rout = map {my $r = Route::User::get($_); $r ? ($r) : ()} $node->users; + $self->send_route($main::mycall, \&pc16, 1, $node, @rout) if @rout && $self->user->wantsendpc16; + } else { + dbg("sent a null value") if isdbg('chanerr'); + } } } } @@ -2126,7 +887,7 @@ sub route my $dxchan = DXChannel->get($call); unless ($dxchan) { my $cl = Route::get($call); - $dxchan = $cl->dxchan if $cl; + $dxchan = $cl->bestdxchan if $cl; if (ref $dxchan) { if (ref $self && $dxchan eq $self) { dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr'); @@ -2205,14 +966,23 @@ sub load_hops # add a ping request to the ping queues sub addping { - my ($from, $to) = @_; + my ($from, $to, $via) = @_; my $ref = $pings{$to} || []; my $r = {}; $r->{call} = $from; $r->{t} = [ gettimeofday ]; - route(undef, $to, pc51($to, $main::mycall, 1)); + if ($via && (my $dxchan = DXChannel->get($via))) { + $dxchan->send(pc51($to, $main::mycall, 1)); + } else { + route(undef, $to, pc51($to, $main::mycall, 1)); + } push @$ref, $r; $pings{$to} = $ref; + my $u = DXUser->get_current($to); + if ($u) { + $u->lastping($main::systime); + $u->put; + } } sub process_rcmd @@ -2302,7 +1072,7 @@ sub addrcmd $rcmds{$to} = $r; my $ref = Route::Node::get($to); - my $dxchan = $ref->dxchan; + my $dxchan = $ref->bestdxchan; if ($dxchan && $dxchan->is_clx) { route(undef, $to, pc84($main::mycall, $to, $self->{call}, $cmd)); } else { @@ -2329,28 +1099,18 @@ sub disconnect my $node = Route::Node::get($call); my @rout; if ($node) { - @rout = $node->del($main::routeroot); - - # and all my ephemera as well + + # remove the route from this node and return a list + # of nodes that have become orphanned as a result. + push @rout, $main::routeroot->remove_route($node, $self); + + # remove all my ephemera as well for (@rout) { my $c = $_->call; eph_del_regex("^PC1[679].*$c"); } } - # remove them from the pc19list as well - while (my ($k,$v) = each %pc19list) { - my @l = grep {$_->[0] ne $call} @{$pc19list{$k}}; - if (@l) { - $pc19list{$k} = \@l; - } else { - delete $pc19list{$k}; - } - - # and the ephemera - eph_del_regex("^PC1[679].*$k"); - } - # unbusy and stop and outgoing mail my $mref = DXMsg::get_busy($call); $mref->stop_msg($call) if $mref; @@ -2358,8 +1118,12 @@ sub disconnect # broadcast to all other nodes that all the nodes connected to via me are gone unless ($pc39flag && $pc39flag == 2) { $self->route_pc21($main::mycall, undef, @rout) if @rout; + $self->route_pc59($main::mycall, "", 'D', hexstamp(), $main::mycall, $node); } + # delete all the unwanted nodes + $_->delete for @rout; + # remove outstanding pings delete $pings{$call}; @@ -2402,6 +1166,12 @@ sub send_route for (; @_ && $no; $no--) { my $r = shift; + + # deal with non routing parameters + unless (ref $r && $r->isa('Route')) { + push @rin, $r; + next; + } if (!$self->{isolate} && $self->{routefilter}) { $filter = undef; @@ -2429,7 +1199,6 @@ sub send_route next unless $routeit; } - $routeit = mungepc91($origin, $routeit) if $self->user->wantpc90; $self->send($routeit); } } @@ -2450,12 +1219,15 @@ sub broadcast_route next if $dxchan == $main::me; next unless $dxchan->isa('DXProt'); next if ($generate == \&pc16 || $generate==\&pc17) && !$dxchan->user->wantsendpc16; - - if ($self->user->wantpc90 && $line) { - $dxchan->send(mungepc91($origin, $line)); + if ($dxchan->{newroute}) { + next if ($generate == \&pc19 || $generate==\&pc21 || + $generate == \&pc16 || $generate==\&pc17); } else { - $dxchan->send_route($origin, $generate, @_); + next if ($generate == \&pc19 || $generate==\&pc21) && !$dxchan->user->wantroutepc19; + next if ($generate == \&pc59); } + + $dxchan->send_route($origin, $generate, @_); } } } @@ -2518,6 +1290,15 @@ sub route_pc50 broadcast_route($self, $origin, \&pc50, $line, 1, @_); } +sub route_pc59 +{ + my $self = shift; + my $origin = shift; + my $line = shift; + + broadcast_route($self, $origin, \&pc59, $line, scalar @_, @_); +} + sub in_filter_route { my $self = shift; @@ -2539,7 +1320,6 @@ sub eph_dup # chop the end off $s =~ s/\^H\d\d?\^?\~?$//; - removepc90($s); $r = 1 if exists $eph{$s}; # pump up the dup if it keeps circulating $eph{$s} = $main::systime + $t; return $r;