From: Dirk Koopman Date: Thu, 21 Jun 2007 13:54:07 +0000 (+0100) Subject: Merge branch 'SIMPLEROUTE' X-Git-Tag: 1.55~160 X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=commitdiff_plain;h=d2580480d24be5e8f1beb4aeeb40980db0dedde0;p=spider.git Merge branch 'SIMPLEROUTE' and tag as 1.55 Conflicts: .gitignore data/.gitignore perl/DXProt.pm perl/Version.pm --- d2580480d24be5e8f1beb4aeeb40980db0dedde0 diff --cc Changes index b1cbb1c9,79166aab..0c3956de --- a/Changes +++ b/Changes @@@ -1,5 -1,13 +1,15 @@@ ++21Jun06======================================================================= ++1. merge back SIMPLEROUTE branch to issue as official 1.54. + 18Jun06======================================================================= + 1. add a optional dependency on Encode (included in 5.8.x) to encode strings + to latin1 for deduping purposes, hopefully getting rid of some dupes. + 2. add a default INPUT filter for a node (by_dxcc ) if no + specific or default INPUT node exists. + 13Jun06======================================================================= + 1. start using git. + 2. change all the version / build numbering. 14Jun07======================================================================= - 1. prepare for git repository and moving of anon cvs repository to + 1. prepare for git repository and moving of anon cvs repository to scm.tobit.co.uk. 11Jun07======================================================================= 1. Change the frequency normalisation for DX Spot dupe checks so that any diff --cc perl/DXProt.pm index 360bb2dd,96a51f5d..ca17f4a6 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@@ -1,2620 -1,1532 +1,1 @@@ --#!/usr/bin/perl --# --# This module impliments the protocal mode for a dx cluster --# --# Copyright (c) 1998 Dirk Koopman G1TLH --# --# $Id$ --# -- --package DXProt; -- --@ISA = qw(DXChannel); -- --use DXUtil; --use DXChannel; --use DXUser; --use DXM; --use DXProtVars; --use DXCommandmode; --use DXLog; --use Spot; --use DXProtout; --use DXDebug; --use Filter; --use Local; --use DXDb; --use AnnTalk; --use Geomag; --use WCY; --use BadWords; --use DXHash; --use Route; --use Route::Node; --use Script; - use Investigate; --use RouteDB; - -use DXProtHandle; -- --use strict; -- --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 $chatimportfn -- $investigation_int $pc19_version $myprot_version -- %nodehops $baddx $badspotter $badnode $censorpc $rspfcheck -- $allowzero $decode_dk0wcy $send_opernam @checklist - $eph_pc15_restime - $eph_pc15_restime $pc92_update_period $last_pc92_update - %pc92_find $pc92_find_timeout -- ); -- --$pc11_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc11 --$pc23_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc23 -- --$last_hour = time; # last time I did an hourly periodic update --%rcmds = (); # outstanding rcmd requests outbound --%nodehops = (); # node specific hop control --%pc19list = (); # list of outstanding PC19s that haven't had PC16s on them -- --$censorpc = 1; # Do a BadWords::check on text fields and reject things -- # loads of 'bad things' --$baddx = new DXHash "baddx"; --$badspotter = new DXHash "badspotter"; --$badnode = new DXHash "badnode"; --$last10 = $last_pc50 = time; --$ann_to_talk = 1; --$rspfcheck = 1; --$eph_restime = 180; --$eph_info_restime = 60*60; --$eph_pc15_restime = 6*60; --$eph_pc34_restime = 30; --$pingint = 5*60; --$obscount = 2; --$chatdupeage = 20 * 60 * 60; --$chatimportfn = "$main::root/chat_import"; --$investigation_int = 12*60*60; # time between checks to see if we can see this node --$pc19_version = 5466; # the visible version no for outgoing PC19s generated from pc59 -$pc92_update_period = 30*60; # the period between PC92 C updates -$last_pc92_update = time + int rand(180); # the last time a PC92 config update -%pc92_find = (); # outstanding pc92 find operations -$pc92_find_timeout = 30; # maximum time to wait for a reply - - -- --@checklist = --( -- [ qw(i c c m bp bc c) ], # pc10 -- [ qw(i f m d t m c c h) ], # pc11 -- [ qw(i c bm m bm bm p h) ], # pc12 -- [ qw(i c h) ], # -- [ qw(i c h) ], # -- [ qw(i c m h) ], # -- undef , # pc16 has to be validated manually -- [ qw(i c c h) ], # pc17 -- [ qw(i m n) ], # pc18 -- undef , # pc19 has to be validated manually -- undef , # pc20 no validation -- [ qw(i c m h) ], # pc21 -- undef , # pc22 no validation -- [ qw(i d n n n n m c c h) ], # pc23 -- [ qw(i c p h) ], # pc24 -- [ qw(i c c n n) ], # pc25 -- [ qw(i f m d t m c c bc) ], # pc26 -- [ qw(i d n n n n m c c bc) ], # pc27 -- [ qw(i c c m c d t p m bp n p bp bc) ], # pc28 -- [ qw(i c c n m) ], # pc29 -- [ qw(i c c n) ], # pc30 -- [ qw(i c c n) ], # pc31 -- [ qw(i c c n) ], # pc32 -- [ qw(i c c n) ], # pc33 -- [ qw(i c c m) ], # pc34 -- [ qw(i c c m) ], # pc35 -- [ qw(i c c m) ], # pc36 -- [ qw(i c c n m) ], # pc37 -- undef, # pc38 not interested -- [ qw(i c m) ], # pc39 -- [ qw(i c c m p n) ], # pc40 -- [ qw(i c n m h) ], # pc41 -- [ qw(i c c n) ], # pc42 -- undef, # pc43 don't handle it -- [ qw(i c c n m m c) ], # pc44 -- [ qw(i c c n m) ], # pc45 -- [ qw(i c c n) ], # pc46 -- undef, # pc47 -- undef, # pc48 -- [ qw(i c m h) ], # pc49 -- [ qw(i c n h) ], # pc50 -- [ qw(i c c n) ], # pc51 -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, # pc60 -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, # pc70 -- undef, -- undef, -- [ qw(i d n n n n n n m m m c c h) ], # pc73 -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, -- undef, # pc80 -- undef, -- undef, -- undef, -- [ qw(i c c c m) ], # pc84 -- [ qw(i c c c m) ], # pc85 -- undef, -- undef, -- undef, -- undef, -- [ qw(i c n) ], # pc90 --); -- --# use the entry in the check list to check the field list presented --# return OK if line NOT in check list (for now) --sub check --{ -- my $n = shift; -- $n -= 10; -- return 0 if $n < 0 || $n > @checklist; -- my $ref = $checklist[$n]; -- return 0 unless ref $ref; -- -- my $i; -- for ($i = 1; $i < @$ref; $i++) { -- my ($blank, $act) = $$ref[$i] =~ /^(b?)(\w)$/; -- return 0 unless $act; -- next if $blank && $_[$i] =~ /^[ \*]$/; -- if ($act eq 'c') { -- return $i unless is_callsign($_[$i]); -- } elsif ($act eq 'i') { -- ; # do nothing -- } elsif ($act eq 'm') { -- return $i unless is_pctext($_[$i]); -- } elsif ($act eq 'p') { -- return $i unless is_pcflag($_[$i]); -- } elsif ($act eq 'f') { -- return $i unless is_freq($_[$i]); -- } elsif ($act eq 'n') { -- return $i unless $_[$i] =~ /^[\d ]+$/; -- } elsif ($act eq 'h') { -- return $i unless $_[$i] =~ /^H\d\d?$/; -- } elsif ($act eq 'd') { -- return $i unless $_[$i] =~ /^\s*\d+-\w\w\w-[12][90]\d\d$/; -- } elsif ($act eq 't') { -- return $i unless $_[$i] =~ /^[012]\d[012345]\dZ$/; -- } -- } -- return 0; --} -- --sub init --{ -- do "$main::data/hop_table.pl" if -e "$main::data/hop_table.pl"; -- confess $@ if $@; -- -- my $user = DXUser->get($main::mycall); -- die "User $main::mycall not setup or disappeared RTFM" unless $user; -- -- $myprot_version += $main::version*100; -- $main::me = DXProt->new($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; - $main::me->{do_pc9x} = 1; --} -- --# --# obtain a new connection this is derived from dxchannel --# -- --sub new --{ -- my $self = DXChannel::alloc(@_); -- -- # add this node to the table, the values get filled in later -- my $pkg = shift; -- my $call = shift; -- -- # if we have an entry already, then send a PC21 to all connect -- # old style connections, because we are about to get the real deal -- if (my $ref = Route::Node::get($call)) { -- dbg("ROUTE: $call is already in the routing table, deleting") if isdbg('route'); -- my @rout = $ref->delete; -- $self->route_pc21($main::mycall, undef, @rout) if @rout; -- } -- $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}; -- $host ||= "AGW Port #$self->{conn}->{agwport}" if exists $self->{conn}->{agwport}; -- $host ||= "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}; - # if there is no route input filter then specify a default one. - # obviously this can be changed later by the sysop. - if (!$self->{inroutefilter}) { - my $dxcc = $self->dxcc; - $Route::filterdef->cmd($self, 'route', 'accept', "input by_dxcc $dxcc" ); - } -- -- # 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()); --} -- --# --# This is the normal pcxx despatcher --# --sub normal --{ -- my ($self, $line) = @_; -- -- if ($line =~ '^<\w+\s' && $main::do_xml) { -- DXXml::normal($self, $line); -- return; -- } -- -- 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 <= 89) { # reject PC9x messages - 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; - } - - # modify the hop count here - if ($self != $main::me) { - if (my ($hops, $trail) = $line =~ /\^H(\d+)(\^?\~?)?$/) { - $trail ||= ''; - $hops--; - return if $hops < 0; - $line =~ s/\^H(\d+)(\^?\~?)?$/sprintf('^H%d%s', $hops, $trail)/e; - $field[-1] = "H$hops"; - } -- } -- - # send it out for processing -- my $origin = $self->{call}; -- 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; - } - } - - # remember a route to this node and also the node on which this user is - RouteDB::update($_[6], $self->{call}); - # RouteDB::update($to, $_[6]); - - # 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; - } - - # can we see an interface to send it down? - - # 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]); - - # is the spotted callsign blank? This should really be trapped earlier but it - # could break other protocol sentences. Also check for lower case characters. - if ($_[2] =~ /^\s*$/) { - dbg("PCPROT: blank callsign, dropped") if isdbg('chanerr'); - return; - } - if ($_[2] =~ /[a-z]/) { - dbg("PCPROT: lowercase characters, dropped") if isdbg('chanerr'); - return; - } - - - # 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; - } - } - - # remember a route - # RouteDB::update($_[7], $self->{call}); - # RouteDB::update($_[6], $_[7]); - - my @spot = Spot::prepare($_[1], $_[2], $d, $_[5], $nossid, $_[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(@spot[0..4,5])) { - 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) { - - # remember a route - # RouteDB::update($_[5], $self->{call}); - # RouteDB::update($_[1], $_[5]); - - # 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); - } - } - - - sub handle_15 - { - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - if (eph_dup($line, $eph_pc15_restime)) { - dbg("PCPROT: Ephemeral dup, dropped") if isdbg('chanerr'); - } else { - unless ($self->{isolate}) { - DXChannel::broadcast_nodes($line, $self) if $line =~ /\^H\d+\^?~?$/; # send it to everyone but me - } - } - } - - # incoming user - sub handle_16 - { - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - # general checks - my $dxchan; - my $ncall = $_[1]; - my $newline = "PC16^"; - - # dos 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 my config from outside!") if isdbg('chanerr'); - return; - } - if (DXChannel::get($ncall) && $ncall ne $self->{call}) { - dbg("PCPROT: trying to alter locally connected $ncall from $self->{call}, ignored") if isdbg('chanerr'); - return; - } - - RouteDB::update($ncall, $self->{call}); - - # do we believe this call? - unless ($ncall eq $self->{call} || $self->is_believed($ncall)) { - if (my $ivp = Investigate::get($ncall, $self->{call})) { - $ivp->store_pcxx($pcno,$line,$origin,@_); - } else { - dbg("PCPROT: We don't believe $ncall on $self->{call}") if isdbg('chanerr'); - } - return; - } - - if (eph_dup($line)) { - dbg("PCPROT: dup PC16 detected") 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); - } - - # send info to all logged in thingies - $self->tell_login('loginu', "$ncall: $call") if DXUser->get_current($ncall)->is_local_node; - $self->tell_buddies('loginb', $call, $ncall); - - # 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; - } - - RouteDB::delete($ncall, $self->{call}); - - # do we believe this call? - unless ($ncall eq $self->{call} || $self->is_believed($ncall)) { - if (my $ivp = Investigate::get($ncall, $self->{call})) { - $ivp->store_pcxx($pcno,$line,$origin,@_); - } else { - dbg("PCPROT: We don't believe $ncall on $self->{call}") 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 = DXChannel::get($ncall); - 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 and then remove user if present - # return unless $self->in_filter_route($parent); - $parent->del_user($uref); - - # send info to all logged in thingies - $self->tell_login('logoutu', "$ncall: $ucall") if DXUser->get_current($ncall)->is_local_node; - $self->tell_buddies('logoutb', $ucall, $ncall); - - 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'); - } - $self->{handle_xml}++ if DXXml::available() && $_[1] =~ /\bxml\b/; - } 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^"; - - # 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->priv(1); # I have relented and defaulted nodes - $user->lockout(1); - $user->homenode($origin); - $user->node($origin); - $user->wantroutepc19(1); - } - $user->sort('A') unless $user->is_node; - $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 unless $ver && $ver =~ /^\d+$/; - 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->priv(1); # I have relented and defaulted nodes - $user->lockout(1); - $user->homenode($call); - $user->node($call); - } - $user->sort('A') unless $user->is_node; - - RouteDB::update($call, $self->{call}); - - # do we believe this call? - my $genline = "PC19^$here^$call^$conf^$ver^$_[-1]^"; - unless ($call eq $self->{call} || $self->is_believed($call)) { - my $pt = $user->lastping($self->{call}) || 0; - if ($pt+$investigation_int < $main::systime && !Investigate::get($call, $self->{call})) { - my $ivp = Investigate->new($call, $self->{call}); - $ivp->version($ver); - $ivp->here($here); - $ivp->store_pcxx($pcno,$genline,$origin,'PC19',$here,$call,$conf,$ver,$_[-1]); - } else { - dbg("PCPROT: We don't believe $call on $self->{call}") if isdbg('chanerr'); - } - $user->put; - next; - } - - if (eph_dup($genline)) { - dbg("PCPROT: dup PC19 for $call detected") if isdbg('chanerr'); - next; - } - - 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; - } - - RouteDB::delete($call, $self->{call}); - - # check if we believe this - unless ($call eq $self->{call} || $self->is_believed($call)) { - if (my $ivp = Investigate::get($call, $self->{call})) { - $ivp->store_pcxx($pcno,$line,$origin,@_); - } else { - dbg("PCPROT: We don't believe $call on $self->{call}") if isdbg('chanerr'); - } - 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; - } - } - - # only do a rspf check on PC23 (not 27) - if ($pcno == 23) { - 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; - } - - # global wwv filtering on INPUT - my @dxcc = ((Prefix::cty_data($_[7]))[0..2], (Prefix::cty_data($_[8]))[0..2]); - if ($self->{inwwvfilter}) { - my ($filter, $hops) = $self->{inwwvfilter}->it(@_[7,8], $origin, @dxcc); - unless ($filter) { - dbg("PCPROT: Rejected by input wwv filter") if isdbg('chanerr'); - return; - } - } - $_[7] =~ s/-\d+$//o; # remove spotter's ssid - if (Geomag::dup($d,$sfi,$k,$i,$_[6],$_[7])) { - dbg("PCPROT: Dup WWV Spot ignored\n") if isdbg('chanerr'); - return; - } - - # note this only takes the first one it gets - 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; - if ($_[1] eq $main::mycall) { - no strict 'refs'; - my $sub = "DXDb::handle_$pcno"; - &$sub($self, @_); - } else { - $self->route($_[1], $line) unless $self->is_clx; - } - } - - # 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) { - if (($_[3] =~ /spotter/i || $_[3] =~ /self/i) && $user->name && $user->name ne $_[3]) { - dbg("PCPROT: invalid name") if isdbg('chanerr'); - return; - } - $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; - - 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; - } - } - - # keep alive/user list - sub handle_50 - { - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - my $call = $_[1]; - - RouteDB::update($call, $self->{call}); - - my $node = Route::Node::get($call); - if ($node) { - return unless $node->call eq $self->{call}; - $node->usercount($_[2]); - - # input filter if required - return unless $self->in_filter_route($node); - - $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]; - - - # is it for us? - if ($to eq $main::mycall) { - if ($flag == 1) { - $self->send(pc51($from, $to, '0')); - } else { - DXXml::Ping::handle_ping_reply($self, $from); - } - } else { - - RouteDB::update($from, $self->{call}); - - if (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); - } - } - - # 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; - } - - my $wcy = WCY::update($d, @_[2..12]); - - my $rep; - eval { - $rep = Local::wcy($self, @_[1..12]); - }; - # dbg("Local::wcy error $@") if isdbg('local') if $@; - return if $rep; - - # broadcast to the eager world - send_wcy_spot($self, $line, $d, @_[2..12]); - } - - # remote commands (incoming) - sub handle_84 - { - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - $self->process_rcmd($_[1], $_[2], $_[3], $_[4]); - } - - # remote command replies - sub handle_85 - { - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - $self->process_rcmd_reply($_[1], $_[2], $_[3], $_[4]); - } - - # 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. - # - # NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be - # REBROADCAST!!!! - # - - sub handle_default - { - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - if (eph_dup($line)) { - dbg("PCPROT: Ephemeral dup, dropped") if isdbg('chanerr'); - } else { - unless ($self->{isolate}) { - DXChannel::broadcast_nodes($line, $self) if $line =~ /\^H\d+\^?~?$/; # send it to everyone but me - } -- } --} -- --# --# This is called from inside the main cluster processing loop and is used --# for despatching commands that are doing some long processing job --# --sub process --{ -- my $t = time; -- my @dxchan = DXChannel::get_all(); -- my $dxchan; -- my $pc50s; -- -- # send out a pc50 on EVERY channel all at once -- if ($t >= $last_pc50 + $DXProt::pc50_interval) { -- $pc50s = pc50($main::me, scalar DXChannel::get_all_users); -- eph_dup($pc50s); -- $last_pc50 = $t; -- } -- -- foreach $dxchan (@dxchan) { -- next unless $dxchan->is_node; -- next if $dxchan->handle_xml; -- next if $dxchan == $main::me; -- -- # send the pc50 -- $dxchan->send($pc50s) if $pc50s; -- -- # send a ping out on this channel -- if ($dxchan->{pingint} && $t >= $dxchan->{pingint} + $dxchan->{lastping}) { -- if ($dxchan->{nopings} <= 0) { -- $dxchan->disconnect; -- } else { -- DXXml::Ping::add($main::me, $dxchan->call); -- $dxchan->{nopings} -= 1; -- $dxchan->{lastping} = $t; -- $dxchan->{lastping} += $dxchan->{pingint} / 2 unless @{$dxchan->{pingtime}}; -- } -- } -- } -- -- Investigate::process(); - clean_pc92_find(); -- -- # every ten seconds -- if ($t - $last10 >= 10) { -- # clean out ephemera -- -- eph_clean(); -- import_chat(); - -- - if ($main::systime >= $last_pc92_update + $pc92_update_period) { - dbg("ROUTE: sending pc92 update") if isdbg('route'); - send_pc92_update(); - time_out_pc92_routes(); - $last_pc92_update = $main::systime + int rand(5*60); - } - -- $last10 = $t; -- } -- -- if ($main::systime - 3600 > $last_hour) { -- $last_hour = $main::systime; -- } --} -- --# --# finish up a pc context --# -- --# --# some active measures --# -- -- --sub send_dx_spot --{ -- my $self = shift; -- my $line = shift; -- my @dxchan = DXChannel::get_all(); -- my $dxchan; -- -- # 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) { -- next if $dxchan == $main::me; -- next if $dxchan == $self && $self->is_node; -- $dxchan->dx_spot($line, $self->{isolate}, @_, $self->{call}); -- } --} -- --sub dx_spot --{ -- my $self = shift; -- my $line = shift; -- my $isolate = shift; -- my ($filter, $hops); -- -- if ($self->{spotsfilter}) { -- ($filter, $hops) = $self->{spotsfilter}->it(@_); -- return unless $filter; -- } -- send_prot_line($self, $filter, $hops, $isolate, $line); --} -- --sub send_prot_line --{ -- my ($self, $filter, $hops, $isolate, $line) = @_; -- my $routeit; -- -- -- if ($hops) { -- $routeit = $line; -- $routeit =~ s/\^H\d+\^\~$/\^H$hops\^\~/; -- } else { -- $routeit = adjust_hops($self, $line); # adjust its hop count by node name -- return unless $routeit; -- } -- if ($filter) { -- $self->send($routeit); -- } else { -- $self->send($routeit) unless $self->{isolate} || $isolate; -- } --} -- -- --sub send_wwv_spot --{ -- my $self = shift; -- my $line = shift; -- my @dxchan = DXChannel::get_all(); -- my $dxchan; -- 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) { -- next if $dxchan == $main::me; -- next if $dxchan == $self && $self->is_node; -- my $routeit; -- my ($filter, $hops); -- -- $dxchan->wwv($line, $self->{isolate}, @_, $self->{call}, @dxcc); -- } --} -- --sub wwv --{ -- my $self = shift; -- my $line = shift; -- my $isolate = shift; -- my ($filter, $hops); -- -- if ($self->{wwvfilter}) { -- ($filter, $hops) = $self->{wwvfilter}->it(@_[7..$#_]); -- return unless $filter; -- } -- send_prot_line($self, $filter, $hops, $isolate, $line) --} -- --sub send_wcy_spot --{ -- my $self = shift; -- my $line = shift; -- my @dxchan = DXChannel::get_all(); -- my $dxchan; -- 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 -- foreach $dxchan (@dxchan) { -- next if $dxchan == $main::me; -- next if $dxchan == $self; -- -- $dxchan->wcy($line, $self->{isolate}, @_, $self->{call}, @dxcc); -- } --} -- --sub wcy --{ -- my $self = shift; -- my $line = shift; -- my $isolate = shift; -- my ($filter, $hops); -- -- if ($self->{wcyfilter}) { -- ($filter, $hops) = $self->{wcyfilter}->it(@_); -- return unless $filter; -- } -- send_prot_line($self, $filter, $hops, $isolate, $line) if $self->is_clx || $self->is_spider || $self->is_dxnet; --} -- --# send an announce --sub send_announce --{ -- my $self = shift; - my $from_pc9x = shift; -- my $line = shift; -- my @dxchan = DXChannel::get_all(); -- my $dxchan; - my $target; - my $target = $_[6]; -- my $to = 'To '; -- my $text = unpad($_[2]); -- -- if ($_[3] eq '*') { # sysops -- $target = "SYSOP"; -- } elsif ($_[3] gt ' ') { # speciality list handling -- my ($name) = split /\./, $_[3]; -- $target = "$name"; # put the rest in later (if bothered) - } - } -- -- if ($_[5] eq '1') { -- $target = "WX"; -- $to = ''; -- } -- $target = "ALL" if !$target; -- -- -- # obtain country codes etc -- my @a = Prefix::cty_data($_[0]); -- my @b = Prefix::cty_data($_[4]); -- if ($self->{inannfilter}) { -- my ($filter, $hops) = -- $self->{inannfilter}->it(@_, $self->{call}, -- @a[0..2], -- @b[0..2], $a[3], $b[3]); -- unless ($filter) { -- dbg("PCPROT: Rejected by input announce filter") if isdbg('chanerr'); -- return; -- } -- } -- -- if (AnnTalk::dup($_[0], $_[1], $_[2])) { -- dbg("PCPROT: Duplicate Announce ignored") if isdbg('chanerr'); -- return; -- } -- -- Log('ann', $target, $_[0], $text); -- -- # 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) { -- next if $dxchan == $main::me; -- next if $dxchan == $self && $self->is_node; - next if $from_pc9x && $dxchan->{do_pc9x}; - next if $target eq 'LOCAL' && $dxchan->is_node; -- $dxchan->announce($line, $self->{isolate}, $to, $target, $text, @_, $self->{call}, -- @a[0..2], @b[0..2]); -- } --} -- --my $msgid = 0; -- --sub nextchatmsgid --{ -- $msgid++; -- $msgid = 1 if $msgid > 999; -- return $msgid; --} -- --# send a chat line --sub send_chat --{ -- my $self = shift; - my $from_pc9x = shift; -- my $line = shift; -- my @dxchan = DXChannel::get_all(); -- my $dxchan; -- my $target = $_[3]; -- my $text = unpad($_[2]); -- my $ak1a_line; -- -- # munge the group and recast the line if required -- if ($target =~ s/\.LST$//) { -- $ak1a_line = $line; -- } -- -- # obtain country codes etc -- my @a = Prefix::cty_data($_[0]); -- my @b = Prefix::cty_data($_[4]); -- if ($self->{inannfilter}) { -- my ($filter, $hops) = -- $self->{inannfilter}->it(@_, $self->{call}, -- @a[0..2], -- @b[0..2], $a[3], $b[3]); -- unless ($filter) { -- dbg("PCPROT: Rejected by input announce filter") if isdbg('chanerr'); -- return; -- } -- } -- -- if (AnnTalk::dup($_[0], $_[1], $_[2], $chatdupeage)) { -- dbg("PCPROT: Duplicate Announce ignored") if isdbg('chanerr'); -- return; -- } -- -- -- Log('chat', $target, $_[0], $text); -- -- # 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) { -- my $is_ak1a = $dxchan->is_ak1a; -- -- if ($dxchan->is_node) { -- next if $dxchan == $main::me; -- next if $dxchan == $self; - next if $from_pc9x && $dxchan->{do_pc9x}; -- next unless $dxchan->is_spider || $is_ak1a; -- next if $target eq 'LOCAL'; -- if (!$ak1a_line && $is_ak1a) { - $ak1a_line = DXProt::pc12($_[0], $text, $_[1], "$target.LST"); - $ak1a_line = pc12($_[0], $text, $_[1], "$target.LST"); -- } -- } -- -- $dxchan->chat($is_ak1a ? $ak1a_line : $line, $self->{isolate}, $target, $_[1], -- $text, @_, $self->{call}, @a[0..2], @b[0..2]); -- } --} -- --sub announce --{ -- my $self = shift; -- my $line = shift; -- my $isolate = shift; -- my $to = shift; -- my $target = shift; -- my $text = shift; -- my ($filter, $hops); -- -- if ($self->{annfilter}) { -- ($filter, $hops) = $self->{annfilter}->it(@_); -- return unless $filter; -- } -- send_prot_line($self, $filter, $hops, $isolate, $line) unless $_[1] eq $main::mycall; --} -- --sub chat --{ -- goto &announce; --} -- -- --sub send_local_config --{ -- my $self = shift; - my $node; - my @nodes; - my @localnodes; - 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->{do_pc9x}) { - $self->send_pc92_config; -- } 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 - my $node; - my @nodes; - my @localnodes; - my @remotenodes; -- - # 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); - 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 -- - my $node; - my @rawintcalls = map { $_->nodes } @localnodes if @localnodes; - my @intcalls; - for $node (@rawintcalls) { - push @intcalls, $node unless grep $node eq $_, @intcalls; - # 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) { - push @intcalls, $node unless grep $node eq $_, @intcalls; - } - my $ref = Route::Node::get($self->{call}); - my @rnodes = $ref->nodes; - for $node (@intcalls) { - push @remotenodes, Route::Node::get($node) unless grep $node eq $_, @rnodes, @remotenodes; - } - $self->send_route($main::mycall, \&pc19, scalar(@remotenodes), @remotenodes); -- } - my $ref = Route::Node::get($self->{call}); - my @rnodes = $ref->nodes; - for $node (@intcalls) { - push @remotenodes, Route::Node::get($node) unless grep $node eq $_, @rnodes, @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'); - } -- } - $self->send_route($main::mycall, \&pc19, scalar(@remotenodes), @remotenodes); -- } -} - -sub gen_my_pc92_config -{ - my $node = shift; -- - # get all the users connected on the above nodes and send them out - foreach $node ($main::routeroot, @localnodes, @remotenodes) { - if ($node->{call} eq $main::mycall) { - my @dxchan = grep { $_->call ne $main::mycall && !$_->{isolate} } DXChannel::get_all(); - dbg("ROUTE: all dxchan: " . join(',', map{$_->{call}} @dxchan)) if isdbg('routelow'); - my @localnodes = map { my $r = Route::get($_->{call}); $r ? $r : () } @dxchan; - dbg("ROUTE: localnodes: " . join(',', map{$_->{call}} @localnodes)) if isdbg('routelow'); - return pc92c($main::routeroot, @localnodes); - } else { - my @rout = map {my $r = Route::User::get($_); $r ? ($r) : ()} $node->users; - return pc92c($node, @rout); - } -} - -sub gen_pc92_update -{ - my $self = shift; - my $with_pc92_nodes = shift; - my $node; - my @lines; - my @dxchan; - my @localnodes; - - dbg('ROUTE: DXProt::gen_pc92_update start') if isdbg('routelow'); - - # send 'my' configuration for all channels - push @lines, gen_my_pc92_config($main::routeroot); - - if ($with_pc92_nodes) { - # send out the configuration of all the directly connected PC92 nodes with current configuration - # but with the dates that the last config came in with. - @dxchan = grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} && $_->{do_pc9x} } DXChannel::get_all_nodes(); - dbg("ROUTE: pc92 dxchan: " . join(',', map{$_->{call}} @dxchan)) if isdbg('routelow'); - @localnodes = map { my $r = Route::Node::get($_->{call}); $r ? $r : () } @dxchan; - dbg("ROUTE: pc92 localnodes: " . join(',', map{$_->{call}} @localnodes)) if isdbg('routelow'); - foreach $node (@localnodes) { - if ($node && $node->lastid->{92}) { - my @rout = map {my $r = Route::get($_); $r ? ($r) : ()} $node->nodes, $node->users; - push @lines, gen_pc92_with_time($node->call, 'C', $node->lastid->{92}, @rout); - } - } - } - - # send the configuration of all the directly connected 'external' nodes that don't handle PC92 - # out with the 'external' marker on the first node. - @dxchan = grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} && !$_->{do_pc9x} } DXChannel::get_all_nodes(); - dbg("ROUTE: non pc92 dxchan: " . join(',', map{$_->{call}} @dxchan)) if isdbg('routelow'); - @localnodes = map { my $r = Route::Node::get($_->{call}); $r ? $r : () } @dxchan; - dbg("ROUTE: non pc92 localnodes: " . join(',', map{$_->{call}} @localnodes)) if isdbg('routelow'); - foreach $node (@localnodes) { -- 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; - push @lines, gen_my_pc92_config($node); - } - } - - dbg('ROUTE: DXProt::gen_pc92_update end with ' . scalar @lines . ' lines') if isdbg('routelow'); - return @lines; -} - - -sub send_pc92_config -{ - my $self = shift; - - dbg('DXProt::send_pc92_config') if isdbg('trace'); - - my @out = $self->gen_pc92_update(1); - - # send the complete config out on this interface - for (@out) { - $self->send($_); - } -} - -sub send_pc92_update -{ - my @out = $main::me->gen_pc92_update(0); - - # broadcast the lines to all PC92 nodes - for (@out) { - $main::me->broadcast_route_pc9x($main::mycall, undef, $_, 0); - } -} - -sub time_out_pc92_routes -{ - my @nodes = grep {$_->call ne $main::mycall && ($_->do_pc9x || $_->via_pc92)} Route::Node::get_all(); - my @rdel; - foreach my $n (@nodes) { - my $o = $n->dec_obs; - if ($o <= 0) { - if (my $dxchan = DXChannel::get($n->call)) { - dbg("ROUTE: disconnecting local pc92 $dxchan->{call} on obscount") if isdbg('route'); - $dxchan->disconnect; - next; - } - my @parents = map {Route::Node::get($_)} $n->parents; - for (@parents) { - if ($_) { - dbg("ROUTE: deleting pc92 $_->{call} from $n->{call} on obscount") if isdbg('route'); - push @rdel, $n->del($_); - } - } -- } else { - dbg("sent a null value") if isdbg('chanerr'); - dbg("ROUTE: obscount on $n->{call} now $o") if isdbg('route'); -- } - } - for (@rdel) { - $main::me->route_pc21($main::mycall, undef, $_) if $_; -- } --} -- --# --# route a message down an appropriate interface for a callsign --# --# is called route(to, pcline); --# -- --sub route --{ -- my ($self, $call, $line) = @_; -- -- if (ref $self && $call eq $self->{call}) { -- dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr'); -- return; -- } -- -- # always send it down the local interface if available -- my $dxchan = DXChannel::get($call); -- if ($dxchan) { -- dbg("route: $call -> $dxchan->{call} direct" ) if isdbg('route'); -- } else { -- my $cl = Route::get($call); -- $dxchan = $cl->dxchan if $cl; -- if (ref $dxchan) { -- if (ref $self && $dxchan eq $self) { -- dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr'); -- return; -- } -- dbg("route: $call -> $dxchan->{call} using normal route" ) if isdbg('route'); -- } -- } -- -- # try the backstop method -- unless ($dxchan) { -- my $rcall = RouteDB::get($call); -- if ($rcall) { -- if ($self && $rcall eq $self->{call}) { -- dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr'); -- return; -- } -- $dxchan = DXChannel::get($rcall); -- dbg("route: $call -> $rcall using RouteDB" ) if isdbg('route') && $dxchan; -- } -- } -- -- if ($dxchan) { -- my $routeit = adjust_hops($dxchan, $line); # adjust its hop count by node name -- if ($routeit) { -- $dxchan->send($routeit) unless $dxchan == $main::me; -- } -- } else { -- dbg("PCPROT: No route available, dropped") if isdbg('chanerr'); -- } --} -- --# --# obtain the hops from the list for this callsign and pc no --# -- --sub get_hops --{ -- my $pcno = shift; -- my $hops = $DXProt::hopcount{$pcno}; -- $hops = $DXProt::def_hopcount if !$hops; -- return "H$hops"; --} -- --# --# adjust the hop count on a per node basis using the user loadable --# hop table if available or else decrement an existing one --# -- --sub adjust_hops --{ -- my $self = shift; -- my $s = shift; -- my $call = $self->{call}; -- my $hops; -- - if (($hops) = $s =~ /\^H(\d+)\^~?$/o) { - if (($hops) = $s =~ /\^H(\d+)\^?~?$/o) { -- my ($pcno) = $s =~ /^PC(\d\d)/o; -- confess "$call called adjust_hops with '$s'" unless $pcno; -- my $ref = $nodehops{$call} if %nodehops; -- if ($ref) { -- my $newhops = $ref->{$pcno}; -- return "" if defined $newhops && $newhops == 0; -- $newhops = $ref->{default} unless $newhops; -- return "" if defined $newhops && $newhops == 0; -- $newhops = $hops if !$newhops; -- $s =~ s/\^H(\d+)(\^~?)$/\^H$newhops$2/ if $newhops; - } else { - # simply decrement it - $hops--; - return "" if !$hops; - $s =~ s/\^H(\d+)(\^~?)$/\^H$hops$2/ if $hops; -- } -- } -- return $s; --} -- --# --# load hop tables --# --sub load_hops --{ -- my $self = shift; -- return $self->msg('lh1') unless -e "$main::data/hop_table.pl"; -- do "$main::data/hop_table.pl"; -- return $@ if $@; -- return (); --} -- --sub process_rcmd --{ -- my ($self, $tonode, $fromnode, $user, $cmd) = @_; -- if ($tonode eq $main::mycall) { -- my $ref = DXUser->get_current($fromnode); -- my $cref = Route::Node::get($fromnode); -- Log('rcmd', 'in', $ref->{priv}, $fromnode, $cmd); -- if ($cmd !~ /^\s*rcmd/i && $cref && $ref && $cref->call eq $ref->homenode) { # not allowed to relay RCMDS! -- if ($ref->{priv}) { # you have to have SOME privilege, the commands have further filtering -- $self->{remotecmd} = 1; # for the benefit of any command that needs to know -- my $oldpriv = $self->{priv}; -- $self->{priv} = $ref->{priv}; # assume the user's privilege level -- my @in = (DXCommandmode::run_cmd($self, $cmd)); -- $self->{priv} = $oldpriv; -- $self->send_rcmd_reply($main::mycall, $fromnode, $user, @in); -- delete $self->{remotecmd}; -- } else { -- $self->send_rcmd_reply($main::mycall, $fromnode, $user, "sorry...!"); -- } -- } else { -- $self->send_rcmd_reply($main::mycall, $fromnode, $user, "your attempt is logged, Tut tut tut...!"); -- } -- } else { -- my $ref = DXUser->get_current($tonode); -- if ($ref && $ref->is_clx) { -- $self->route($tonode, pc84($fromnode, $tonode, $user, $cmd)); -- } else { -- $self->route($tonode, pc34($fromnode, $tonode, $cmd)); -- } -- } --} -- --sub process_rcmd_reply --{ -- my ($self, $tonode, $fromnode, $user, $line) = @_; -- if ($tonode eq $main::mycall) { -- my $s = $rcmds{$fromnode}; -- if ($s) { -- my $dxchan = DXChannel::get($s->{call}); -- my $ref = $user eq $tonode ? $dxchan : (DXChannel::get($user) || $dxchan); -- $ref->send($line) if $ref; -- delete $rcmds{$fromnode} if !$dxchan; -- } else { -- # send unsolicited ones to the sysop -- my $dxchan = DXChannel::get($main::myalias); -- $dxchan->send($line) if $dxchan; -- } -- } else { -- my $ref = DXUser->get_current($tonode); -- if ($ref && $ref->is_clx) { -- $self->route($tonode, pc85($fromnode, $tonode, $user, $line)); -- } else { -- $self->route($tonode, pc35($fromnode, $tonode, $line)); -- } -- } --} -- --sub send_rcmd_reply --{ -- my $self = shift; -- my $tonode = shift; -- my $fromnode = shift; -- my $user = shift; -- while (@_) { -- my $line = shift; -- $line =~ s/\s*$//; -- Log('rcmd', 'out', $fromnode, $line); -- if ($self->is_clx) { -- $self->send(pc85($main::mycall, $fromnode, $user, "$main::mycall:$line")); -- } else { -- $self->send(pc35($main::mycall, $fromnode, "$main::mycall:$line")); -- } -- } --} -- --# add a rcmd request to the rcmd queues --sub addrcmd --{ -- my ($self, $to, $cmd) = @_; -- -- my $r = {}; -- $r->{call} = $self->{call}; -- $r->{t} = $main::systime; -- $r->{cmd} = $cmd; -- $rcmds{$to} = $r; -- -- my $ref = Route::Node::get($to); -- my $dxchan = $ref->dxchan; -- if ($dxchan && $dxchan->is_clx) { -- route(undef, $to, pc84($main::mycall, $to, $self->{call}, $cmd)); -- } else { -- route(undef, $to, pc34($main::mycall, $to, $cmd)); -- } --} -- --sub disconnect --{ -- my $self = shift; -- my $pc39flag = shift; -- my $call = $self->call; -- -- return if $self->{disconnecting}++; -- -- unless ($pc39flag && $pc39flag == 1) { -- $self->send_now("D", DXProt::pc39($main::mycall, $self->msg('disc1', "System Op"))); -- } -- -- # get rid of any PC16/17/19 -- eph_del_regex("^PC1[679]*$call"); -- -- # do routing stuff, remove me from routing table -- my $node = Route::Node::get($call); -- my @rout; -- if ($node) { -- @rout = $node->del($main::routeroot); -- -- # and all my ephemera as well -- for (@rout) { -- my $c = $_->call; -- eph_del_regex("^PC1[679].*$c"); -- } -- } -- -- RouteDB::delete_interface($call); -- - # 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; -- -- # broadcast to all other nodes that all the nodes connected to via me are gone - unless ($pc39flag && $pc39flag == 2) { - unless ($pc39flag && $pc39flag == 2) { -- $self->route_pc21($main::mycall, undef, @rout) if @rout; - $self->route_pc92d($main::mycall, undef, $main::routeroot, $node) if $node; -- } -- -- # remove outstanding pings -- delete $pings{$call}; -- -- # I was the last node visited -- $self->user->node($main::mycall); -- -- # send info to all logged in thingies -- $self->tell_login('logoutn'); -- -- Log('DXProt', $call . " Disconnected"); -- -- $self->SUPER::disconnect; --} -- -- --# --# send a talk message to this thingy --# --sub talk --{ -- my ($self, $from, $to, $via, $line, $origin) = @_; -- - $line =~ s/\^/\\5E/g; # remove any ^ characters - $self->send(DXProt::pc10($from, $to, $via, $line, $origin)); - Log('talk', $to, $from, $via?$via:$self->call, $line) unless $origin && $origin ne $main::mycall; - if ($self->{do_pc9x}) { - $self->send(pc93($to, $from, $via, $line)); - } else { - $self->send(pc10($from, $to, $via, $line, $origin)); - } - Log('talk', $to, $from, '>' . ($via || $origin || $self->call), $line) unless $origin && $origin ne $main::mycall; --} -- --# 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 -- --sub send_route --{ -- my $self = shift; -- my $origin = shift; -- my $generate = shift; -- my $no = shift; # the no of things to filter on -- my $routeit; -- my ($filter, $hops); -- my @rin; -- -- for (; @_ && $no; $no--) { -- my $r = shift; -- -- if (!$self->{isolate} && $self->{routefilter}) { -- $filter = undef; -- if ($r) { -- ($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}); -- if ($filter) { -- push @rin, $r; -- } else { -- dbg("DXPROT: $self->{call}/" . $r->call . " rejected by output filter") if isdbg('chanerr'); -- } -- } else { -- dbg("was sent a null value") if isdbg('chanerr'); -- } -- } else { -- push @rin, $r unless $self->{isolate} && $r->call ne $main::mycall; -- } -- } -- if (@rin) { -- foreach my $line (&$generate(@rin, @_)) { -- if ($hops) { -- $routeit = $line; -- $routeit =~ s/\^H\d+\^\~$/\^H$hops\^\~/; -- } else { -- $routeit = adjust_hops($self, $line); # adjust its hop count by node name -- next unless $routeit; -- } -- -- $self->send($routeit); -- } -- } --} -- --sub broadcast_route --{ -- my $self = shift; -- my $origin = shift; -- my $generate = shift; -- my $line = shift; -- my @dxchan = DXChannel::get_all_nodes(); -- my $dxchan; - - - if ($line) { - $line =~ /\^H(\d+)\^?\~?$/; - return unless $1 > 0; - } -- unless ($self->{isolate}) { -- foreach $dxchan (@dxchan) { -- next if $dxchan == $self; -- next if $dxchan == $main::me; -- next unless $dxchan->isa('DXProt'); - next if $dxchan->{do_pc9x}; -- next if ($generate == \&pc16 || $generate==\&pc17) && !$dxchan->user->wantsendpc16; -- -- $dxchan->send_route($origin, $generate, @_); - } - } -} - -# this is only used for next door nodes on init -sub send_route_pc92 -{ - my $self = shift; - - return unless $self->{do_pc9x}; - - my $origin = shift; - my $generate = shift; - my $no = shift; # the no of things to filter on - my $line; - - $line = &$generate(@_); - $self->send($line); -} - -sub broadcast_route_pc9x -{ - my $self = shift; - my $origin = shift; - my $generate = shift; - my $line = shift; - my $no = shift; - my @dxchan = DXChannel::get_all_nodes(); - my $dxchan; - - if ($origin eq $main::mycall && $generate && !$line) { - $line = &$generate(@_); - } - - $line =~ /\^H(\d+)\^\~?$/; - unless ($1 > 0 && $self->{isolate}) { - foreach $dxchan (@dxchan) { - next if $dxchan == $self || $dxchan == $main::me; - next if $origin eq $dxchan->{call}; # don't route some from this call back again. - next unless $dxchan->{do_pc9x}; - next unless $dxchan->isa('DXProt'); - - $dxchan->send($line); -- } -- } --} -- --sub route_pc16 --{ -- my $self = shift; -- return unless $self->user->wantpc16; -- my $origin = shift; -- my $line = shift; -- broadcast_route($self, $origin, \&pc16, $line, 1, @_); --} -- --sub route_pc17 --{ -- my $self = shift; -- return unless $self->user->wantpc16; -- my $origin = shift; -- my $line = shift; -- broadcast_route($self, $origin, \&pc17, $line, 1, @_); --} -- --sub route_pc19 --{ -- my $self = shift; -- my $origin = shift; -- my $line = shift; -- broadcast_route($self, $origin, \&pc19, $line, scalar @_, @_); --} -- --sub route_pc21 --{ -- my $self = shift; -- my $origin = shift; -- my $line = shift; -- broadcast_route($self, $origin, \&pc21, $line, scalar @_, @_); --} -- --sub route_pc24 --{ -- my $self = shift; -- my $origin = shift; -- my $line = shift; -- broadcast_route($self, $origin, \&pc24, $line, 1, @_); --} -- --sub route_pc41 --{ -- my $self = shift; -- my $origin = shift; -- my $line = shift; -- broadcast_route($self, $origin, \&pc41, $line, 1, @_); --} -- --sub route_pc50 --{ -- my $self = shift; -- my $origin = shift; -- my $line = shift; -- broadcast_route($self, $origin, \&pc50, $line, 1, @_); -} - -sub route_pc92c -{ - my $self = shift; - my $origin = shift; - my $line = shift; - broadcast_route_pc9x($self, $origin, \&pc92c, $line, 1, @_); -} - -sub route_pc92a -{ - my $self = shift; - my $origin = shift; - my $line = shift; - broadcast_route_pc9x($self, $origin, \&pc92a, $line, 1, @_); -} - -sub route_pc92d -{ - my $self = shift; - my $origin = shift; - my $line = shift; - broadcast_route_pc9x($self, $origin, \&pc92d, $line, 1, @_); --} -- --sub in_filter_route --{ -- my $self = shift; -- my $r = shift; -- my ($filter, $hops) = (1, 1); -- -- if ($self->{inroutefilter}) { -- ($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); -- dbg("PCPROT: $self->{call}/" . $r->call . ' rejected by in_filter_route') if !$filter && isdbg('chanerr'); -- } -- return $filter; --} -- --sub eph_dup --{ -- my $s = shift; -- my $t = shift || $eph_restime; -- my $r; -- -- # chop the end off -- $s =~ s/\^H\d\d?\^?\~?$//; -- $r = 1 if exists $eph{$s}; # pump up the dup if it keeps circulating -- $eph{$s} = $main::systime + $t; -- dbg("PCPROT: emphemeral duplicate") if $r && isdbg('chanerr'); -- return $r; --} -- --sub eph_del_regex --{ -- my $regex = shift; -- my ($key, $val); -- while (($key, $val) = each %eph) { -- if ($key =~ m{$regex}) { -- delete $eph{$key}; -- } -- } --} -- --sub eph_clean --{ -- my ($key, $val); -- -- while (($key, $val) = each %eph) { -- if ($main::systime >= $val) { -- delete $eph{$key}; -- } -- } --} -- --sub eph_list --{ -- my ($key, $val); -- my @out; -- -- while (($key, $val) = each %eph) { -- push @out, $key, $val; -- } -- return @out; --} -- --sub run_cmd --{ -- goto &DXCommandmode::run_cmd; --} -- -- --# import any msgs in the chat directory --# the messages are sent to the chat group which forms the --# the first part of the name (eg: solar.1243.txt would be --# sent to chat group SOLAR) --# --# Each message found is sent: one non-blank line to one chat --# message. So 4 lines = 4 chat messages. --# --# The special name LOCAL is for local users ANN --# The special name ALL is for ANN/FULL --# The special name SYSOP is for ANN/SYSOP --# --sub import_chat --{ -- # are there any to do in this directory? -- return unless -d $chatimportfn; -- unless (opendir(DIR, $chatimportfn)) { -- dbg("can\'t open $chatimportfn $!") if isdbg('msg'); -- Log('msg', "can\'t open $chatimportfn $!"); -- return; -- } -- -- my @names = readdir(DIR); -- closedir(DIR); -- my $name; -- foreach $name (@names) { -- next if $name =~ /^\./; -- my $splitit = $name =~ /^split/; -- my $fn = "$chatimportfn/$name"; -- next unless -f $fn; -- unless (open(MSG, $fn)) { -- dbg("can\'t open import file $fn $!") if isdbg('msg'); -- Log('msg', "can\'t open import file $fn $!"); -- unlink($fn); -- next; -- } -- my @msg = map { s/\r?\n$//; $_ } ; -- close(MSG); -- unlink($fn); -- -- my @cat = split /\./, $name; -- my $target = uc $cat[0]; -- -- foreach my $text (@msg) { -- next unless $text && $text !~ /^\s*#/; -- if ($target eq 'ALL' || $target eq 'LOCAL' || $target eq 'SYSOP') { -- my $sysopflag = $target eq 'SYSOP' ? '*' : ' '; -- if ($target ne 'LOCAL') { -- send_announce($main::me, pc12($main::mycall, $text, '*', $sysopflag), $main::mycall, '*', $text, $sysopflag, $main::mycall, '0'); -- } else { -- Log('ann', 'LOCAL', $main::mycall, $text); -- DXChannel::broadcast_list("To LOCAL de ${main::mycall}: $text\a", 'ann', undef, DXCommandmode->get_all()); -- } -- } else { -- my $msgid = nextchatmsgid(); -- $text = "#$msgid $text"; -- send_chat($main::me, pc12($main::mycall, $text, '*', $target), $main::mycall, '*', $text, $target, $main::mycall, '0'); -- } -- } - } -} - -# start a pc92 find operation -sub start_pc92_find -{ - my $dxchan = shift; - my $target = shift; - my $key = "$dxchan->{call}|$target"; - if ($pc92_find{$key}) { - -- } -} - -# function (not method) to handle pc92 find returns -sub handle_pc92_find_reply -{ - my ($dxchan, $node, $from, $target, $flag, $ms) = @_; - - $dxchan->print_pc92_find_reply($node, $target, $flag, $ms) if $dxchan->can('print_pc92_find_return'); --} - -sub clean_pc92_find -{ -- -} --1; --__END__ ++#!/usr/bin/perl## This module impliments the protocal mode for a dx cluster## Copyright (c) 1998 Dirk Koopman G1TLH## $Id$#package DXProt;@ISA = qw(DXChannel);use DXUtil;use DXChannel;use DXUser;use DXM;use DXProtVars;use DXCommandmode;use DXLog;use Spot;use DXProtout;use DXDebug;use Filter;use Local;use DXDb;use AnnTalk;use Geomag;use WCY;use BadWords;use DXHash;use Route;use Route::Node;use Script;use RouteDB;use DXProtHandle;use strict;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 $chatimportfn $investigation_int $pc19_version $myprot_version %nodehops $baddx $badspotter $badnode $censorpc $rspfcheck $allowzero $decode_dk0wcy $send_opernam @checklist $eph_pc15_restime $pc92_update_period $last_pc92_update %pc92_find $pc92_find_timeout );$pc11_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc11$pc23_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc23$last_hour = time; # last time I did an hourly periodic update%rcmds = (); # outstanding rcmd requests outbound%nodehops = (); # node specific hop control%pc19list = (); # list of outstanding PC19s that haven't had PC16s on them$censorpc = 1; # Do a BadWords::check on text fields and reject things # loads of 'bad things'$baddx = new DXHash "baddx";$badspotter = new DXHash "badspotter";$badnode = new DXHash "badnode";$last10 = $last_pc50 = time;$ann_to_talk = 1;$rspfcheck = 1;$eph_restime = 180;$eph_info_restime = 60*60;$eph_pc15_restime = 6*60;$eph_pc34_restime = 30;$pingint = 5*60;$obscount = 2;$chatdupeage = 20 * 60 * 60;$chatimportfn = "$main::root/chat_import";$investigation_int = 12*60*60; # time between checks to see if we can see this node$pc19_version = 5466; # the visible version no for outgoing PC19s generated from pc59$pc92_update_period = 30*60; # the period between PC92 C updates$last_pc92_update = time + int rand(180); # the last time a PC92 config update%pc92_find = (); # outstanding pc92 find operations$pc92_find_timeout = 30; # maximum time to wait for a reply@checklist =( [ qw(i c c m bp bc c) ], # pc10 [ qw(i f m d t m c c h) ], # pc11 [ qw(i c bm m bm bm p h) ], # pc12 [ qw(i c h) ], # [ qw(i c h) ], # [ qw(i c m h) ], # undef , # pc16 has to be validated manually [ qw(i c c h) ], # pc17 [ qw(i m n) ], # pc18 undef , # pc19 has to be validated manually undef , # pc20 no validation [ qw(i c m h) ], # pc21 undef , # pc22 no validation [ qw(i d n n n n m c c h) ], # pc23 [ qw(i c p h) ], # pc24 [ qw(i c c n n) ], # pc25 [ qw(i f m d t m c c bc) ], # pc26 [ qw(i d n n n n m c c bc) ], # pc27 [ qw(i c c m c d t p m bp n p bp bc) ], # pc28 [ qw(i c c n m) ], # pc29 [ qw(i c c n) ], # pc30 [ qw(i c c n) ], # pc31 [ qw(i c c n) ], # pc32 [ qw(i c c n) ], # pc33 [ qw(i c c m) ], # pc34 [ qw(i c c m) ], # pc35 [ qw(i c c m) ], # pc36 [ qw(i c c n m) ], # pc37 undef, # pc38 not interested [ qw(i c m) ], # pc39 [ qw(i c c m p n) ], # pc40 [ qw(i c n m h) ], # pc41 [ qw(i c c n) ], # pc42 undef, # pc43 don't handle it [ qw(i c c n m m c) ], # pc44 [ qw(i c c n m) ], # pc45 [ qw(i c c n) ], # pc46 undef, # pc47 undef, # pc48 [ qw(i c m h) ], # pc49 [ qw(i c n h) ], # pc50 [ qw(i c c n) ], # pc51 undef, undef, undef, undef, undef, undef, undef, undef, undef, # pc60 undef, undef, undef, undef, undef, undef, undef, undef, undef, undef, # pc70 undef, undef, [ qw(i d n n n n n n m m m c c h) ], # pc73 undef, undef, undef, undef, undef, undef, undef, # pc80 undef, undef, undef, [ qw(i c c c m) ], # pc84 [ qw(i c c c m) ], # pc85 undef, undef, undef, undef, [ qw(i c n) ], # pc90);# use the entry in the check list to check the field list presented# return OK if line NOT in check list (for now)sub check{ my $n = shift; $n -= 10; return 0 if $n < 0 || $n > @checklist; my $ref = $checklist[$n]; return 0 unless ref $ref; my $i; for ($i = 1; $i < @$ref; $i++) { my ($blank, $act) = $$ref[$i] =~ /^(b?)(\w)$/; return 0 unless $act; next if $blank && $_[$i] =~ /^[ \*]$/; if ($act eq 'c') { return $i unless is_callsign($_[$i]); } elsif ($act eq 'i') { ; # do nothing } elsif ($act eq 'm') { return $i unless is_pctext($_[$i]); } elsif ($act eq 'p') { return $i unless is_pcflag($_[$i]); } elsif ($act eq 'f') { return $i unless is_freq($_[$i]); } elsif ($act eq 'n') { return $i unless $_[$i] =~ /^[\d ]+$/; } elsif ($act eq 'h') { return $i unless $_[$i] =~ /^H\d\d?$/; } elsif ($act eq 'd') { return $i unless $_[$i] =~ /^\s*\d+-\w\w\w-[12][90]\d\d$/; } elsif ($act eq 't') { return $i unless $_[$i] =~ /^[012]\d[012345]\dZ$/; } } return 0;}sub init{ do "$main::data/hop_table.pl" if -e "$main::data/hop_table.pl"; confess $@ if $@; my $user = DXUser->get($main::mycall); die "User $main::mycall not setup or disappeared RTFM" unless $user; $myprot_version += $main::version*100; $main::me = DXProt->new($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; $main::me->{do_pc9x} = 1;}## obtain a new connection this is derived from dxchannel#sub new{ my $self = DXChannel::alloc(@_); # add this node to the table, the values get filled in later my $pkg = shift; my $call = shift; # if we have an entry already, then send a PC21 to all connect # old style connections, because we are about to get the real deal if (my $ref = Route::Node::get($call)) { dbg("ROUTE: $call is already in the routing table, deleting") if isdbg('route'); my @rout = $ref->delete; $self->route_pc21($main::mycall, undef, @rout) if @rout; } $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}; $host ||= "AGW Port #$self->{conn}->{agwport}" if exists $self->{conn}->{agwport}; $host ||= "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}; # if there is no route input filter then specify a default one. # obviously this can be changed later by the sysop. if (!$self->{inroutefilter}) { my $dxcc = $self->dxcc; $Route::filterdef->cmd($self, 'route', 'accept', "input by_dxcc $dxcc" ); } # 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());}## This is the normal pcxx despatcher#sub normal{ my ($self, $line) = @_; if ($line =~ '^<\w+\s' && $main::do_xml) { DXXml::normal($self, $line); return; } 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; } # modify the hop count here if ($self != $main::me) { if (my ($hops, $trail) = $line =~ /\^H(\d+)(\^?\~?)?$/) { $trail ||= ''; $hops--; return if $hops < 0; $line =~ s/\^H(\d+)(\^?\~?)?$/sprintf('^H%d%s', $hops, $trail)/e; $field[-1] = "H$hops"; } } # send it out for processing my $origin = $self->{call}; 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); }}## This is called from inside the main cluster processing loop and is used# for despatching commands that are doing some long processing job#sub process{ my $t = time; my @dxchan = DXChannel::get_all(); my $dxchan; my $pc50s; # send out a pc50 on EVERY channel all at once if ($t >= $last_pc50 + $DXProt::pc50_interval) { $pc50s = pc50($main::me, scalar DXChannel::get_all_users); eph_dup($pc50s); $last_pc50 = $t; } foreach $dxchan (@dxchan) { next unless $dxchan->is_node; next if $dxchan->handle_xml; next if $dxchan == $main::me; # send the pc50 $dxchan->send($pc50s) if $pc50s; # send a ping out on this channel if ($dxchan->{pingint} && $t >= $dxchan->{pingint} + $dxchan->{lastping}) { if ($dxchan->{nopings} <= 0) { $dxchan->disconnect; } else { DXXml::Ping::add($main::me, $dxchan->call); $dxchan->{nopings} -= 1; $dxchan->{lastping} = $t; $dxchan->{lastping} += $dxchan->{pingint} / 2 unless @{$dxchan->{pingtime}}; } } } Investigate::process(); clean_pc92_find(); # every ten seconds if ($t - $last10 >= 10) { # clean out ephemera eph_clean(); import_chat(); if ($main::systime >= $last_pc92_update + $pc92_update_period) { dbg("ROUTE: sending pc92 update") if isdbg('route'); send_pc92_update(); time_out_pc92_routes(); $last_pc92_update = $main::systime + int rand(5*60); } $last10 = $t; } if ($main::systime - 3600 > $last_hour) { $last_hour = $main::systime; }}## finish up a pc context### some active measures#sub send_dx_spot{ my $self = shift; my $line = shift; my @dxchan = DXChannel::get_all(); my $dxchan; # 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) { next if $dxchan == $main::me; next if $dxchan == $self && $self->is_node; $dxchan->dx_spot($line, $self->{isolate}, @_, $self->{call}); }}sub dx_spot{ my $self = shift; my $line = shift; my $isolate = shift; my ($filter, $hops); if ($self->{spotsfilter}) { ($filter, $hops) = $self->{spotsfilter}->it(@_); return unless $filter; } send_prot_line($self, $filter, $hops, $isolate, $line);}sub send_prot_line{ my ($self, $filter, $hops, $isolate, $line) = @_; my $routeit; if ($hops) { $routeit = $line; $routeit =~ s/\^H\d+\^\~$/\^H$hops\^\~/; } else { $routeit = adjust_hops($self, $line); # adjust its hop count by node name return unless $routeit; } if ($filter) { $self->send($routeit); } else { $self->send($routeit) unless $self->{isolate} || $isolate; }}sub send_wwv_spot{ my $self = shift; my $line = shift; my @dxchan = DXChannel::get_all(); my $dxchan; 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) { next if $dxchan == $main::me; next if $dxchan == $self && $self->is_node; my $routeit; my ($filter, $hops); $dxchan->wwv($line, $self->{isolate}, @_, $self->{call}, @dxcc); }}sub wwv{ my $self = shift; my $line = shift; my $isolate = shift; my ($filter, $hops); if ($self->{wwvfilter}) { ($filter, $hops) = $self->{wwvfilter}->it(@_[7..$#_]); return unless $filter; } send_prot_line($self, $filter, $hops, $isolate, $line)}sub send_wcy_spot{ my $self = shift; my $line = shift; my @dxchan = DXChannel::get_all(); my $dxchan; 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 foreach $dxchan (@dxchan) { next if $dxchan == $main::me; next if $dxchan == $self; $dxchan->wcy($line, $self->{isolate}, @_, $self->{call}, @dxcc); }}sub wcy{ my $self = shift; my $line = shift; my $isolate = shift; my ($filter, $hops); if ($self->{wcyfilter}) { ($filter, $hops) = $self->{wcyfilter}->it(@_); return unless $filter; } send_prot_line($self, $filter, $hops, $isolate, $line) if $self->is_clx || $self->is_spider || $self->is_dxnet;}# send an announcesub send_announce{ my $self = shift; my $from_pc9x = shift; my $line = shift; my @dxchan = DXChannel::get_all(); my $dxchan; my $target = $_[6]; my $to = 'To '; my $text = unpad($_[2]); if ($_[3] eq '*') { # sysops $target = "SYSOP"; } elsif ($_[3] gt ' ') { # speciality list handling my ($name) = split /\./, $_[3]; $target = "$name"; # put the rest in later (if bothered) } if ($_[5] eq '1') { $target = "WX"; $to = ''; } $target = "ALL" if !$target; # obtain country codes etc my @a = Prefix::cty_data($_[0]); my @b = Prefix::cty_data($_[4]); if ($self->{inannfilter}) { my ($filter, $hops) = $self->{inannfilter}->it(@_, $self->{call}, @a[0..2], @b[0..2], $a[3], $b[3]); unless ($filter) { dbg("PCPROT: Rejected by input announce filter") if isdbg('chanerr'); return; } } if (AnnTalk::dup($_[0], $_[1], $_[2])) { dbg("PCPROT: Duplicate Announce ignored") if isdbg('chanerr'); return; } Log('ann', $target, $_[0], $text); # 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) { next if $dxchan == $main::me; next if $dxchan == $self && $self->is_node; next if $from_pc9x && $dxchan->{do_pc9x}; next if $target eq 'LOCAL' && $dxchan->is_node; $dxchan->announce($line, $self->{isolate}, $to, $target, $text, @_, $self->{call}, @a[0..2], @b[0..2]); }}my $msgid = 0;sub nextchatmsgid{ $msgid++; $msgid = 1 if $msgid > 999; return $msgid;}# send a chat linesub send_chat{ my $self = shift; my $from_pc9x = shift; my $line = shift; my @dxchan = DXChannel::get_all(); my $dxchan; my $target = $_[3]; my $text = unpad($_[2]); my $ak1a_line; # munge the group and recast the line if required if ($target =~ s/\.LST$//) { $ak1a_line = $line; } # obtain country codes etc my @a = Prefix::cty_data($_[0]); my @b = Prefix::cty_data($_[4]); if ($self->{inannfilter}) { my ($filter, $hops) = $self->{inannfilter}->it(@_, $self->{call}, @a[0..2], @b[0..2], $a[3], $b[3]); unless ($filter) { dbg("PCPROT: Rejected by input announce filter") if isdbg('chanerr'); return; } } if (AnnTalk::dup($_[0], $_[1], $_[2], $chatdupeage)) { dbg("PCPROT: Duplicate Announce ignored") if isdbg('chanerr'); return; } Log('chat', $target, $_[0], $text); # 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) { my $is_ak1a = $dxchan->is_ak1a; if ($dxchan->is_node) { next if $dxchan == $main::me; next if $dxchan == $self; next if $from_pc9x && $dxchan->{do_pc9x}; next unless $dxchan->is_spider || $is_ak1a; next if $target eq 'LOCAL'; if (!$ak1a_line && $is_ak1a) { $ak1a_line = pc12($_[0], $text, $_[1], "$target.LST"); } } $dxchan->chat($is_ak1a ? $ak1a_line : $line, $self->{isolate}, $target, $_[1], $text, @_, $self->{call}, @a[0..2], @b[0..2]); }}sub announce{ my $self = shift; my $line = shift; my $isolate = shift; my $to = shift; my $target = shift; my $text = shift; my ($filter, $hops); if ($self->{annfilter}) { ($filter, $hops) = $self->{annfilter}->it(@_); return unless $filter; } send_prot_line($self, $filter, $hops, $isolate, $line) unless $_[1] eq $main::mycall;}sub chat{ goto &announce;}sub send_local_config{ my $self = shift; dbg('DXProt::send_local_config') if isdbg('trace'); # send our nodes if ($self->{do_pc9x}) { $self->send_pc92_config; } else { my $node; my @nodes; my @localnodes; my @remotenodes; 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) { push @intcalls, $node unless grep $node eq $_, @intcalls; } my $ref = Route::Node::get($self->{call}); my @rnodes = $ref->nodes; for $node (@intcalls) { push @remotenodes, Route::Node::get($node) unless grep $node eq $_, @rnodes, @remotenodes; } $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'); } } }}sub gen_my_pc92_config{ my $node = shift; if ($node->{call} eq $main::mycall) { my @dxchan = grep { $_->call ne $main::mycall && !$_->{isolate} } DXChannel::get_all(); dbg("ROUTE: all dxchan: " . join(',', map{$_->{call}} @dxchan)) if isdbg('routelow'); my @localnodes = map { my $r = Route::get($_->{call}); $r ? $r : () } @dxchan; dbg("ROUTE: localnodes: " . join(',', map{$_->{call}} @localnodes)) if isdbg('routelow'); return pc92c($main::routeroot, @localnodes); } else { my @rout = map {my $r = Route::User::get($_); $r ? ($r) : ()} $node->users; return pc92c($node, @rout); }}sub gen_pc92_update{ my $self = shift; my $with_pc92_nodes = shift; my $node; my @lines; my @dxchan; my @localnodes; dbg('ROUTE: DXProt::gen_pc92_update start') if isdbg('routelow'); # send 'my' configuration for all channels push @lines, gen_my_pc92_config($main::routeroot); if ($with_pc92_nodes) { # send out the configuration of all the directly connected PC92 nodes with current configuration # but with the dates that the last config came in with. @dxchan = grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} && $_->{do_pc9x} } DXChannel::get_all_nodes(); dbg("ROUTE: pc92 dxchan: " . join(',', map{$_->{call}} @dxchan)) if isdbg('routelow'); @localnodes = map { my $r = Route::Node::get($_->{call}); $r ? $r : () } @dxchan; dbg("ROUTE: pc92 localnodes: " . join(',', map{$_->{call}} @localnodes)) if isdbg('routelow'); foreach $node (@localnodes) { if ($node && $node->lastid->{92}) { my @rout = map {my $r = Route::get($_); $r ? ($r) : ()} $node->nodes, $node->users; push @lines, gen_pc92_with_time($node->call, 'C', $node->lastid->{92}, @rout); } } } # send the configuration of all the directly connected 'external' nodes that don't handle PC92 # out with the 'external' marker on the first node. @dxchan = grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} && !$_->{do_pc9x} } DXChannel::get_all_nodes(); dbg("ROUTE: non pc92 dxchan: " . join(',', map{$_->{call}} @dxchan)) if isdbg('routelow'); @localnodes = map { my $r = Route::Node::get($_->{call}); $r ? $r : () } @dxchan; dbg("ROUTE: non pc92 localnodes: " . join(',', map{$_->{call}} @localnodes)) if isdbg('routelow'); foreach $node (@localnodes) { if ($node) { push @lines, gen_my_pc92_config($node); } } dbg('ROUTE: DXProt::gen_pc92_update end with ' . scalar @lines . ' lines') if isdbg('routelow'); return @lines;}sub send_pc92_config{ my $self = shift; dbg('DXProt::send_pc92_config') if isdbg('trace'); my @out = $self->gen_pc92_update(1); # send the complete config out on this interface for (@out) { $self->send($_); }}sub send_pc92_update{ my @out = $main::me->gen_pc92_update(0); # broadcast the lines to all PC92 nodes for (@out) { $main::me->broadcast_route_pc9x($main::mycall, undef, $_, 0); }}sub time_out_pc92_routes{ my @nodes = grep {$_->call ne $main::mycall && ($_->do_pc9x || $_->via_pc92)} Route::Node::get_all(); my @rdel; foreach my $n (@nodes) { my $o = $n->dec_obs; if ($o <= 0) { if (my $dxchan = DXChannel::get($n->call)) { dbg("ROUTE: disconnecting local pc92 $dxchan->{call} on obscount") if isdbg('route'); $dxchan->disconnect; next; } my @parents = map {Route::Node::get($_)} $n->parents; for (@parents) { if ($_) { dbg("ROUTE: deleting pc92 $_->{call} from $n->{call} on obscount") if isdbg('route'); push @rdel, $n->del($_); } } } else { dbg("ROUTE: obscount on $n->{call} now $o") if isdbg('route'); } } for (@rdel) { $main::me->route_pc21($main::mycall, undef, $_) if $_; }}## route a message down an appropriate interface for a callsign## is called route(to, pcline);#sub route{ my ($self, $call, $line) = @_; if (ref $self && $call eq $self->{call}) { dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr'); return; } # always send it down the local interface if available my $dxchan = DXChannel::get($call); if ($dxchan) { dbg("route: $call -> $dxchan->{call} direct" ) if isdbg('route'); } else { my $cl = Route::get($call); $dxchan = $cl->dxchan if $cl; if (ref $dxchan) { if (ref $self && $dxchan eq $self) { dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr'); return; } dbg("route: $call -> $dxchan->{call} using normal route" ) if isdbg('route'); } } # try the backstop method unless ($dxchan) { my $rcall = RouteDB::get($call); if ($rcall) { if ($self && $rcall eq $self->{call}) { dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr'); return; } $dxchan = DXChannel::get($rcall); dbg("route: $call -> $rcall using RouteDB" ) if isdbg('route') && $dxchan; } } if ($dxchan) { my $routeit = adjust_hops($dxchan, $line); # adjust its hop count by node name if ($routeit) { $dxchan->send($routeit) unless $dxchan == $main::me; } } else { dbg("PCPROT: No route available, dropped") if isdbg('chanerr'); }}## obtain the hops from the list for this callsign and pc no#sub get_hops{ my $pcno = shift; my $hops = $DXProt::hopcount{$pcno}; $hops = $DXProt::def_hopcount if !$hops; return "H$hops";}## adjust the hop count on a per node basis using the user loadable# hop table if available or else decrement an existing one#sub adjust_hops{ my $self = shift; my $s = shift; my $call = $self->{call}; my $hops; if (($hops) = $s =~ /\^H(\d+)\^?~?$/o) { my ($pcno) = $s =~ /^PC(\d\d)/o; confess "$call called adjust_hops with '$s'" unless $pcno; my $ref = $nodehops{$call} if %nodehops; if ($ref) { my $newhops = $ref->{$pcno}; return "" if defined $newhops && $newhops == 0; $newhops = $ref->{default} unless $newhops; return "" if defined $newhops && $newhops == 0; $newhops = $hops if !$newhops; $s =~ s/\^H(\d+)(\^~?)$/\^H$newhops$2/ if $newhops; } } return $s;}## load hop tables#sub load_hops{ my $self = shift; return $self->msg('lh1') unless -e "$main::data/hop_table.pl"; do "$main::data/hop_table.pl"; return $@ if $@; return ();}sub process_rcmd{ my ($self, $tonode, $fromnode, $user, $cmd) = @_; if ($tonode eq $main::mycall) { my $ref = DXUser->get_current($fromnode); my $cref = Route::Node::get($fromnode); Log('rcmd', 'in', $ref->{priv}, $fromnode, $cmd); if ($cmd !~ /^\s*rcmd/i && $cref && $ref && $cref->call eq $ref->homenode) { # not allowed to relay RCMDS! if ($ref->{priv}) { # you have to have SOME privilege, the commands have further filtering $self->{remotecmd} = 1; # for the benefit of any command that needs to know my $oldpriv = $self->{priv}; $self->{priv} = $ref->{priv}; # assume the user's privilege level my @in = (DXCommandmode::run_cmd($self, $cmd)); $self->{priv} = $oldpriv; $self->send_rcmd_reply($main::mycall, $fromnode, $user, @in); delete $self->{remotecmd}; } else { $self->send_rcmd_reply($main::mycall, $fromnode, $user, "sorry...!"); } } else { $self->send_rcmd_reply($main::mycall, $fromnode, $user, "your attempt is logged, Tut tut tut...!"); } } else { my $ref = DXUser->get_current($tonode); if ($ref && $ref->is_clx) { $self->route($tonode, pc84($fromnode, $tonode, $user, $cmd)); } else { $self->route($tonode, pc34($fromnode, $tonode, $cmd)); } }}sub process_rcmd_reply{ my ($self, $tonode, $fromnode, $user, $line) = @_; if ($tonode eq $main::mycall) { my $s = $rcmds{$fromnode}; if ($s) { my $dxchan = DXChannel::get($s->{call}); my $ref = $user eq $tonode ? $dxchan : (DXChannel::get($user) || $dxchan); $ref->send($line) if $ref; delete $rcmds{$fromnode} if !$dxchan; } else { # send unsolicited ones to the sysop my $dxchan = DXChannel::get($main::myalias); $dxchan->send($line) if $dxchan; } } else { my $ref = DXUser->get_current($tonode); if ($ref && $ref->is_clx) { $self->route($tonode, pc85($fromnode, $tonode, $user, $line)); } else { $self->route($tonode, pc35($fromnode, $tonode, $line)); } }}sub send_rcmd_reply{ my $self = shift; my $tonode = shift; my $fromnode = shift; my $user = shift; while (@_) { my $line = shift; $line =~ s/\s*$//; Log('rcmd', 'out', $fromnode, $line); if ($self->is_clx) { $self->send(pc85($main::mycall, $fromnode, $user, "$main::mycall:$line")); } else { $self->send(pc35($main::mycall, $fromnode, "$main::mycall:$line")); } }}# add a rcmd request to the rcmd queuessub addrcmd{ my ($self, $to, $cmd) = @_; my $r = {}; $r->{call} = $self->{call}; $r->{t} = $main::systime; $r->{cmd} = $cmd; $rcmds{$to} = $r; my $ref = Route::Node::get($to); my $dxchan = $ref->dxchan; if ($dxchan && $dxchan->is_clx) { route(undef, $to, pc84($main::mycall, $to, $self->{call}, $cmd)); } else { route(undef, $to, pc34($main::mycall, $to, $cmd)); }}sub disconnect{ my $self = shift; my $pc39flag = shift; my $call = $self->call; return if $self->{disconnecting}++; unless ($pc39flag && $pc39flag == 1) { $self->send_now("D", DXProt::pc39($main::mycall, $self->msg('disc1', "System Op"))); } # get rid of any PC16/17/19 eph_del_regex("^PC1[679]*$call"); # do routing stuff, remove me from routing table my $node = Route::Node::get($call); my @rout; if ($node) { @rout = $node->del($main::routeroot); # and all my ephemera as well for (@rout) { my $c = $_->call; eph_del_regex("^PC1[679].*$c"); } } RouteDB::delete_interface($call); # unbusy and stop and outgoing mail my $mref = DXMsg::get_busy($call); $mref->stop_msg($call) if $mref; # 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_pc92d($main::mycall, undef, $main::routeroot, $node) if $node; } # remove outstanding pings delete $pings{$call}; # I was the last node visited $self->user->node($main::mycall); # send info to all logged in thingies $self->tell_login('logoutn'); Log('DXProt', $call . " Disconnected"); $self->SUPER::disconnect;}## send a talk message to this thingy#sub talk{ my ($self, $from, $to, $via, $line, $origin) = @_; if ($self->{do_pc9x}) { $self->send(pc93($to, $from, $via, $line)); } else { $self->send(pc10($from, $to, $via, $line, $origin)); } Log('talk', $to, $from, '>' . ($via || $origin || $self->call), $line) unless $origin && $origin ne $main::mycall;}# 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 onsub send_route{ my $self = shift; my $origin = shift; my $generate = shift; my $no = shift; # the no of things to filter on my $routeit; my ($filter, $hops); my @rin; for (; @_ && $no; $no--) { my $r = shift; if (!$self->{isolate} && $self->{routefilter}) { $filter = undef; if ($r) { ($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}); if ($filter) { push @rin, $r; } else { dbg("DXPROT: $self->{call}/" . $r->call . " rejected by output filter") if isdbg('chanerr'); } } else { dbg("was sent a null value") if isdbg('chanerr'); } } else { push @rin, $r unless $self->{isolate} && $r->call ne $main::mycall; } } if (@rin) { foreach my $line (&$generate(@rin, @_)) { if ($hops) { $routeit = $line; $routeit =~ s/\^H\d+\^\~$/\^H$hops\^\~/; } else { $routeit = adjust_hops($self, $line); # adjust its hop count by node name next unless $routeit; } $self->send($routeit); } }}sub broadcast_route{ my $self = shift; my $origin = shift; my $generate = shift; my $line = shift; my @dxchan = DXChannel::get_all_nodes(); my $dxchan; if ($line) { $line =~ /\^H(\d+)\^?\~?$/; return unless $1 > 0; } unless ($self->{isolate}) { foreach $dxchan (@dxchan) { next if $dxchan == $self; next if $dxchan == $main::me; next unless $dxchan->isa('DXProt'); next if $dxchan->{do_pc9x}; next if ($generate == \&pc16 || $generate==\&pc17) && !$dxchan->user->wantsendpc16; $dxchan->send_route($origin, $generate, @_); } }}# this is only used for next door nodes on initsub send_route_pc92{ my $self = shift; return unless $self->{do_pc9x}; my $origin = shift; my $generate = shift; my $no = shift; # the no of things to filter on my $line; $line = &$generate(@_); $self->send($line);}sub broadcast_route_pc9x{ my $self = shift; my $origin = shift; my $generate = shift; my $line = shift; my $no = shift; my @dxchan = DXChannel::get_all_nodes(); my $dxchan; if ($origin eq $main::mycall && $generate && !$line) { $line = &$generate(@_); } $line =~ /\^H(\d+)\^\~?$/; unless ($1 > 0 && $self->{isolate}) { foreach $dxchan (@dxchan) { next if $dxchan == $self || $dxchan == $main::me; next if $origin eq $dxchan->{call}; # don't route some from this call back again. next unless $dxchan->{do_pc9x}; next unless $dxchan->isa('DXProt'); $dxchan->send($line); } }}sub route_pc16{ my $self = shift; return unless $self->user->wantpc16; my $origin = shift; my $line = shift; broadcast_route($self, $origin, \&pc16, $line, 1, @_);}sub route_pc17{ my $self = shift; return unless $self->user->wantpc16; my $origin = shift; my $line = shift; broadcast_route($self, $origin, \&pc17, $line, 1, @_);}sub route_pc19{ my $self = shift; my $origin = shift; my $line = shift; broadcast_route($self, $origin, \&pc19, $line, scalar @_, @_);}sub route_pc21{ my $self = shift; my $origin = shift; my $line = shift; broadcast_route($self, $origin, \&pc21, $line, scalar @_, @_);}sub route_pc24{ my $self = shift; my $origin = shift; my $line = shift; broadcast_route($self, $origin, \&pc24, $line, 1, @_);}sub route_pc41{ my $self = shift; my $origin = shift; my $line = shift; broadcast_route($self, $origin, \&pc41, $line, 1, @_);}sub route_pc50{ my $self = shift; my $origin = shift; my $line = shift; broadcast_route($self, $origin, \&pc50, $line, 1, @_);}sub route_pc92c{ my $self = shift; my $origin = shift; my $line = shift; broadcast_route_pc9x($self, $origin, \&pc92c, $line, 1, @_);}sub route_pc92a{ my $self = shift; my $origin = shift; my $line = shift; broadcast_route_pc9x($self, $origin, \&pc92a, $line, 1, @_);}sub route_pc92d{ my $self = shift; my $origin = shift; my $line = shift; broadcast_route_pc9x($self, $origin, \&pc92d, $line, 1, @_);}sub in_filter_route{ my $self = shift; my $r = shift; my ($filter, $hops) = (1, 1); if ($self->{inroutefilter}) { ($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); dbg("PCPROT: $self->{call}/" . $r->call . ' rejected by in_filter_route') if !$filter && isdbg('chanerr'); } return $filter;}sub eph_dup{ my $s = shift; my $t = shift || $eph_restime; my $r; # chop the end off $s =~ s/\^H\d\d?\^?\~?$//; $r = 1 if exists $eph{$s}; # pump up the dup if it keeps circulating $eph{$s} = $main::systime + $t; dbg("PCPROT: emphemeral duplicate") if $r && isdbg('chanerr'); return $r;}sub eph_del_regex{ my $regex = shift; my ($key, $val); while (($key, $val) = each %eph) { if ($key =~ m{$regex}) { delete $eph{$key}; } }}sub eph_clean{ my ($key, $val); while (($key, $val) = each %eph) { if ($main::systime >= $val) { delete $eph{$key}; } }}sub eph_list{ my ($key, $val); my @out; while (($key, $val) = each %eph) { push @out, $key, $val; } return @out;}sub run_cmd{ goto &DXCommandmode::run_cmd;}# import any msgs in the chat directory# the messages are sent to the chat group which forms the# the first part of the name (eg: solar.1243.txt would be# sent to chat group SOLAR)## Each message found is sent: one non-blank line to one chat# message. So 4 lines = 4 chat messages.## The special name LOCAL is for local users ANN# The special name ALL is for ANN/FULL# The special name SYSOP is for ANN/SYSOP#sub import_chat{ # are there any to do in this directory? return unless -d $chatimportfn; unless (opendir(DIR, $chatimportfn)) { dbg("can\'t open $chatimportfn $!") if isdbg('msg'); Log('msg', "can\'t open $chatimportfn $!"); return; } my @names = readdir(DIR); closedir(DIR); my $name; foreach $name (@names) { next if $name =~ /^\./; my $splitit = $name =~ /^split/; my $fn = "$chatimportfn/$name"; next unless -f $fn; unless (open(MSG, $fn)) { dbg("can\'t open import file $fn $!") if isdbg('msg'); Log('msg', "can\'t open import file $fn $!"); unlink($fn); next; } my @msg = map { s/\r?\n$//; $_ } ; close(MSG); unlink($fn); my @cat = split /\./, $name; my $target = uc $cat[0]; foreach my $text (@msg) { next unless $text && $text !~ /^\s*#/; if ($target eq 'ALL' || $target eq 'LOCAL' || $target eq 'SYSOP') { my $sysopflag = $target eq 'SYSOP' ? '*' : ' '; if ($target ne 'LOCAL') { send_announce($main::me, pc12($main::mycall, $text, '*', $sysopflag), $main::mycall, '*', $text, $sysopflag, $main::mycall, '0'); } else { Log('ann', 'LOCAL', $main::mycall, $text); DXChannel::broadcast_list("To LOCAL de ${main::mycall}: $text\a", 'ann', undef, DXCommandmode->get_all()); } } else { my $msgid = nextchatmsgid(); $text = "#$msgid $text"; send_chat($main::me, pc12($main::mycall, $text, '*', $target), $main::mycall, '*', $text, $target, $main::mycall, '0'); } } }}# start a pc92 find operationsub start_pc92_find{ my $dxchan = shift; my $target = shift; my $key = "$dxchan->{call}|$target"; if ($pc92_find{$key}) { }}# function (not method) to handle pc92 find returnssub handle_pc92_find_reply{ my ($dxchan, $node, $from, $target, $flag, $ms) = @_; $dxchan->print_pc92_find_reply($node, $target, $flag, $ms) if $dxchan->can('print_pc92_find_return');}sub clean_pc92_find{}1;__END__ diff --cc perl/DXProtHandle.pm index 00000000,d6ae6cfa..d38067ee mode 000000,100644..100644 --- a/perl/DXProtHandle.pm +++ b/perl/DXProtHandle.pm @@@ -1,0 -1,1804 +1,1 @@@ -# -# -# This module impliments the handlers for the protocal mode for a dx cluster -# -# Copyright (c) 1998-2006 Dirk Koopman G1TLH -# -# $Id$ -# - -package DXProt; - -@ISA = qw(DXChannel); - -use DXUtil; -use DXChannel; -use DXUser; -use DXM; -use DXProtVars; -use DXCommandmode; -use DXLog; -use Spot; -use DXProtout; -use DXDebug; -use Filter; -use Local; -use DXDb; -use AnnTalk; -use Geomag; -use WCY; -use BadWords; -use DXHash; -use Route; -use Route::Node; -use Script; -use RouteDB; - - -use strict; - -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 $chatimportfn - $investigation_int $pc19_version $myprot_version - %nodehops $baddx $badspotter $badnode $censorpc $rspfcheck - $allowzero $decode_dk0wcy $send_opernam @checklist - $eph_pc15_restime $pc9x_past_age $pc9x_future_age - ); - -$pc9x_past_age = 15*60; # maximum age in the past of a px9x -$pc9x_future_age = 5*60; # maximum age in the future ditto - -# 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; - } - } - - # remember a route to this node and also the node on which this user is - RouteDB::update($_[6], $self->{call}); -# RouteDB::update($to, $_[6]); - - # convert this to a PC93 and process it as such - $self->normal(pc93($to, $from, $via, $_[3], $_[6])); - return; - - # this is all redundant but kept for now for reference - - # 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; - } - - # can we see an interface to send it down? - - # 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]); - - # is the spotted callsign blank? This should really be trapped earlier but it - # could break other protocol sentences. Also check for lower case characters. - if ($_[2] =~ /^\s*$/) { - dbg("PCPROT: blank callsign, dropped") if isdbg('chanerr'); - return; - } - if ($_[2] =~ /[a-z]/) { - dbg("PCPROT: lowercase characters, dropped") if isdbg('chanerr'); - return; - } - - - # 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; - } - } - - # remember a route -# RouteDB::update($_[7], $self->{call}); -# RouteDB::update($_[6], $_[7]); - - my @spot = Spot::prepare($_[1], $_[2], $d, $_[5], $nossid, $_[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(@spot[0..4,5])) { - 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(0, $line, @_[1..6]); - } elsif ($_[2] eq '*' || $_[2] eq $main::mycall) { - - # remember a route -# RouteDB::update($_[5], $self->{call}); -# RouteDB::update($_[1], $_[5]); - - # 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(0, $line, @_[1..6]); - } else { - $self->route($_[2], $line); - } -} - -sub handle_15 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - if (eph_dup($line, $eph_pc15_restime)) { - dbg("PCPROT: Ephemeral dup, dropped") if isdbg('chanerr'); - } else { - unless ($self->{isolate}) { - DXChannel::broadcast_nodes($line, $self) if $line =~ /\^H\d+\^?~?$/; # send it to everyone but me - } - } -} - -# incoming user -sub handle_16 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - # general checks - my $dxchan; - my $ncall = $_[1]; - my $newline = "PC16^"; - - # dos 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 $h; - $h = 1 if DXChannel::get($ncall); - RouteDB::update($ncall, $self->{call}, $h); - if ($h && $self->{call} ne $ncall) { - dbg("PCPROT: trying to update a local node, ignored") if isdbg('chanerr'); - return; - } - - if (eph_dup($line)) { - dbg("PCPROT: dup PC16 detected") if isdbg('chanerr'); - return; - } - - my $parent = Route::Node::get($ncall); - - if ($parent) { - $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); - } else { - $parent = Route::Node->new($ncall); - } - - unless ($h) { - if ($parent->via_pc92) { - dbg("PCPROT: non-local node controlled by PC92, ignored") if isdbg('chanerr'); - return; - } - } - - 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 $h && $au; - } else { - my @ans = $parent->add_user($call, $flags); - push @rout, @ans if $h && @ans; - } - - # send info to all logged in thingies - $self->tell_login('loginu', "$ncall: $call") if DXUser->get_current($ncall)->is_local_node; - $self->tell_buddies('loginb', $call, $ncall); - - # 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; - } - if (@rout) { - $self->route_pc16($origin, $line, $parent, @rout) if @rout; -# $self->route_pc92a($main::mycall, undef, $parent, @rout) if $h && $self->{state} eq 'normal'; - } -} - -# 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; - } - - RouteDB::delete($ncall, $self->{call}); - - 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 = DXChannel::get($ncall); - if ($dxchan && $dxchan ne $self) { - dbg("PCPROT: PC17 from $self->{call} trying to alter locally connected $ncall, ignored!") if isdbg('chanerr'); - return; - } - - unless ($dxchan) { - if ($parent->via_pc92) { - dbg("PCPROT: non-local node controlled by PC92, ignored") if isdbg('chanerr'); - return; - } - } - - if (DXChannel::get($ucall)) { - dbg("PCPROT: trying do disconnect local user, ignored") if isdbg('chanerr'); - return; - } - - # input filter if required and then remove user if present -# return unless $self->in_filter_route($parent); - $parent->del_user($uref); - - # send info to all logged in thingies - $self->tell_login('logoutu', "$ncall: $ucall") if DXUser->get_current($ncall)->is_local_node; - $self->tell_buddies('logoutb', $ucall, $ncall); - - if (eph_dup($line)) { - dbg("PCPROT: dup PC17 detected") if isdbg('chanerr'); - return; - } - - $self->route_pc17($origin, $line, $parent, $uref); -# $self->route_pc92d($main::mycall, undef, $parent, $uref) if $dxchan; -} - -# 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'); - } - $self->{handle_xml}++ if DXXml::available() && $_[1] =~ /\bxml/; - if ($_[1] =~ /\bpc9x/) { - $self->{do_pc9x} = 1; - dbg("Do px9x set on $self->{call}"); - } - } 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()); -} - -sub check_add_node -{ - my $call = shift; - - # 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->priv(1); # I have relented and defaulted nodes - $user->lockout(1); - $user->homenode($call); - $user->node($call); - } - $user->sort('A') unless $user->is_node; - return $user; -} - -# incoming cluster list -sub handle_19 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - my $i; - my $newline = "PC19^"; - - # new routing list - my (@rout, @pc92out); - - # 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; - } - - my $h; - - # parse the PC19 - # - # We are making a major change from now on. We are only going to accept - # PC19s from directly connected nodes. This means that we are probably - # going to throw away most of the data that we are being sent. - # - # The justification for this is that most of it is wrong or out of date - # anyway. - # - # From now on we are only going to believe PC92 data and locally connected - # non-pc92 nodes. - # - 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 unless $ver && $ver =~ /^\d+$/; - 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 - $h = 0; - my $dxchan = DXChannel::get($call); - if ($dxchan) { - if ($dxchan == $self) { - $h = 1; - } else { - dbg("PCPROT: PC19 from $self->{call} trying to alter wrong locally connected $call, ignored!") if isdbg('chanerr'); - next; - } - } - - my $user = check_add_node($call); - -# if (eph_dup($genline)) { -# dbg("PCPROT: dup PC19 for $call detected") if isdbg('chanerr'); -# next; -# } - - RouteDB::update($call, $self->{call}, $dxchan ? 1 : undef); - - unless ($h) { - if ($parent->via_pc92) { - dbg("PCPROT: non-local node controlled by PC92, ignored") if isdbg('chanerr'); - next; - } - } - - 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; - } else { - 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; - push @pc92out, $r if $h; - } else { - next; - } - } - } - - # 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; - } - - # we are not automatically sending out PC19s, we send out a composite PC21,PC19 instead - # but remember there will only be one (pair) these because any extras will be - # thrown away. - if (@rout) { -# $self->route_pc21($self->{call}, $line, @rout); - $self->route_pc19($self->{call}, $line, @rout); - } - if (@pc92out) { - $self->route_pc92a($main::mycall, $line, $main::routeroot, @pc92out) if $self->{state} eq 'normal'; - } -} - -sub send_delayed_pc92 -{ - my $self = shift; - - # send out new PC92 config to everyone else - my $line = gen_my_pc92_config($main::me); - $self->broadcast_route_pc9x($main::mycall, undef, $line, 0); - - # if this is an external node then send out the external config - unless ($self->{do_pc9x}) { - $line = gen_my_pc92_config(Route::Node::get($self->{call})); - $self->broadcast_route_pc9x($main::mycall, undef, $line, 0); - } -} - -# send local configuration -sub handle_20 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - if ($self->{do_pc9x} && $self->{state} ne 'init92') { - dbg("PCPROT: disconnecting because login call not sent in any pc92") if isdbg('chanerr'); - $self->send("**** You logged in with $self->{call} but that is NOT your \$mycall"); - $self->disconnect; - return; - } - $self->send_local_config(); - $self->send(pc22()); - $self->state('normal'); - $self->{lastping} = 0; - $self->send_delayed_pc92; -} - -# delete a cluster from the list -# -# This should never occur for directly connected nodes. -# -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 ignore it - if ($call eq $self->call) { - dbg("PCPROT: self referencing PC21 from $self->{call}"); - return; - } - - RouteDB::delete($call, $self->{call}); - - my $parent = Route::Node::get($self->{call}); - unless ($parent) { - dbg("PCPROT: my parent $self->{call} has disappeared"); - $self->disconnect; - return; - } - - my @rout; - - if ($call ne $main::mycall) { # don't allow malicious buggers to disconnect me! - my $node = Route::Node::get($call); - if ($node) { - - if ($node->via_pc92) { - dbg("PCPROT: controlled by PC92, ignored") if isdbg('chanerr'); - return; - } - - 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, force a PC21 if it is local - push @rout, $node->del($parent); - push @rout, $call if $dxchan && @rout == 0; - } - } else { - dbg("PCPROT: I WILL _NOT_ be disconnected!") if isdbg('chanerr'); - return; - } - - if (eph_dup($line)) { - dbg("PCPROT: dup PC21 detected") if isdbg('chanerr'); - return; - } - - if (@rout) { - $self->route_pc21($origin, $line, @rout); -# $self->route_pc92d($main::mycall, $line, $main::routeroot, @rout); - } -} - - -sub handle_22 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - if ($self->{do_pc9x}) { - if ($self->{state} ne 'init92') { - dbg("PCPROT: disconnecting because login call not sent in any pc92") if isdbg('chanerr'); - $self->send("**** You logged in with $self->{call} but that is NOT your \$mycall"); - $self->disconnect; - return; - } - } - $self->{lastping} = 0; - $self->state('normal'); - $self->send_delayed_pc92; -} - -# 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; - } - } - - # only do a rspf check on PC23 (not 27) - if ($pcno == 23) { - 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; - } - - # global wwv filtering on INPUT - my @dxcc = ((Prefix::cty_data($_[7]))[0..2], (Prefix::cty_data($_[8]))[0..2]); - if ($self->{inwwvfilter}) { - my ($filter, $hops) = $self->{inwwvfilter}->it(@_[7,8], $origin, @dxcc); - unless ($filter) { - dbg("PCPROT: Rejected by input wwv filter") if isdbg('chanerr'); - return; - } - } - $_[7] =~ s/-\d+$//o; # remove spotter's ssid - if (Geomag::dup($d,$sfi,$k,$i,$_[6],$_[7])) { - dbg("PCPROT: Dup WWV Spot ignored\n") if isdbg('chanerr'); - return; - } - - # note this only takes the first one it gets - 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; - if ($_[1] eq $main::mycall) { - no strict 'refs'; - my $sub = "DXDb::handle_$pcno"; - &$sub($self, @_); - } else { - $self->route($_[1], $line) unless $self->is_clx; - } -} - -# 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 $sort = $_[2]; - my $val = $_[3]; - - my $l = "PC41^$call^$sort"; - 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 ($val eq $sort || $val =~ /^\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 ($sort == 1) { - if (($val =~ /spotter/i || $val =~ /self/i) && $user->name && $user->name ne $val) { - dbg("PCPROT: invalid name") if isdbg('chanerr'); - if ($main::mycall eq 'GB7DJK' || $main::mycall eq 'GB7BAA' || $main::mycall eq 'WR3D') { - DXChannel::broadcast_nodes(pc41($_[1], 1, $user->name)); # send it to everyone including me - } - return; - } - $user->name($val); - } elsif ($sort == 2) { - $user->qth($val); - } elsif ($sort == 3) { - if (is_latlong($val)) { - my ($lat, $long) = DXBearing::stoll($val); - $user->lat($lat) if $lat; - $user->long($long) if $long; - $user->qra(DXBearing::lltoqra($lat, $long)) unless $user->qra; - } else { - dbg('PCPROT: not a valid lat/long') if isdbg('chanerr'); - return; - } - } elsif ($sort == 4) { - $user->homenode($val); - } elsif ($sort == 5) { - if (is_qra(uc $val)) { - my ($lat, $long) = DXBearing::qratoll(uc $val); - $user->lat($lat) if $lat && !$user->lat; - $user->long($long) if $long && !$user->long; - $user->qra(uc $val); - } 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, $sort, $val, $_[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; - - 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; - } -} - -# keep alive/user list -sub handle_50 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - my $call = $_[1]; - - RouteDB::update($call, $self->{call}); - - my $node = Route::Node::get($call); - if ($node) { - return unless $node->call eq $self->{call}; - $node->usercount($_[2]); - - # input filter if required - return unless $self->in_filter_route($node); - - $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]; - - - # is it for us? - if ($to eq $main::mycall) { - if ($flag == 1) { - $self->send(pc51($from, $to, '0')); - } else { - DXXml::Ping::handle_ping_reply($self, $from); - } - } else { - - RouteDB::update($from, $self->{call}); - - if (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); - } -} - -# 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; - } - - my $wcy = WCY::update($d, @_[2..12]); - - my $rep; - eval { - $rep = Local::wcy($self, @_[1..12]); - }; - # dbg("Local::wcy error $@") if isdbg('local') if $@; - return if $rep; - - # broadcast to the eager world - send_wcy_spot($self, $line, $d, @_[2..12]); -} - -# remote commands (incoming) -sub handle_84 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - $self->process_rcmd($_[1], $_[2], $_[3], $_[4]); -} - -# remote command replies -sub handle_85 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - $self->process_rcmd_reply($_[1], $_[2], $_[3], $_[4]); -} - -# decode a pc92 call: flag call : version : build -sub _decode_pc92_call -{ - my $icall = shift; - my @part = split /:/, $icall; - my ($flag, $call) = unpack "A A*", $part[0]; - return () unless defined $flag && $flag ge '0' && $flag le '7'; - return () unless $call && is_callsign($call); - my $is_node = $flag & 4; - my $is_extnode = $flag & 2; - my $here = $flag & 1; - return ($call, $is_node, $is_extnode, $here, $part[1], $part[2]); -} - -# decode a pc92 call: flag call : version : build -sub _encode_pc92_call -{ - my $ref = shift; - - # plain call or value - return $ref unless ref $ref; - - my $ext = shift; - my $flag = 0; - my $call = $ref->call; - my $extra = ''; - $flag |= $ref->here ? 1 : 0; - if ($ref->isa('Route::Node') || $ref->isa('DXProt')) { - $flag |= 4; - my $dxchan = DXChannel::get($call); - $flag |= 2 if $call ne $main::mycall && $dxchan && !$dxchan->{do_pc9x}; - if ($ext) { - if ($ref->version) { - my $version = $ref->version || 1.0; - $version = $version * 100 + 5300 if $version < 50; - $extra .= ":" . $version; - } - } - } - return "$flag$call$extra"; -} - -sub _add_thingy -{ - my $parent = shift; - my $s = shift; - my ($call, $is_node, $is_extnode, $here, $version, $build) = @$s; - my @rout; - - if ($call) { - if ($is_node) { - dbg("ROUTE: added node $call to " . $parent->call) if isdbg('routelow'); - @rout = $parent->add($call, $version, Route::here($here)); - } else { - dbg("ROUTE: added user $call to " . $parent->call) if isdbg('routelow'); - @rout = $parent->add_user($call, Route::here($here)); - } - } - return @rout; -} - -sub _del_thingy -{ - my $parent = shift; - my $s = shift; - my ($call, $is_node, $is_extnode, $here, $version, $build) = @$s; - my @rout; - if ($call) { - if ($is_node) { - my $nref = Route::Node::get($call); - dbg("ROUTE: deleting node $call from " . $parent->call) if isdbg('routelow'); - @rout = $nref->del($parent) if $nref; - } else { - my $uref = Route::User::get($call); - dbg("ROUTE: deleting user $call from " . $parent->call) if isdbg('routelow'); - @rout = $parent->del_user($uref) if $uref; - } - } - return @rout; -} - -my $_last_time; -my $_last_occurs; - -sub gen_pc9x_t -{ - if (!$_last_time || $_last_time != $main::systime) { - $_last_time = $main::systime; - $_last_occurs = 0; - return $_last_time - $main::systime_daystart; - } else { - $_last_occurs++; - return sprintf "%d.%02d", $_last_time - $main::systime_daystart, $_last_occurs; - } -} - -sub check_pc9x_t -{ - my $call = shift; - my $t = shift; - my $pc = shift; - my $create = shift; - - my $parent = ref $call ? $call : Route::Node::get($call); - if ($parent) { - # we only do this for external calls whose routing table - # record come and go. The reference for mycall is permanent - # and not that frequently used, it also never times out, so - # the id on it is completely unreliable. Besides, only commands - # originating on this box will go through this code... - if ($parent->call ne $main::mycall) { - my $lastid = $parent->lastid->{$pc} || 0; - if ($t < $lastid) { - if (my $d = $lastid-86400+$t > $pc9x_past_age) { - dbg("PCPROT: $call id $t <= $lastid, ignored") if isdbg('chanerr'); - return; - } - } - if ($lastid == $t) { - dbg("PCPROT: dup id on $call = $lastid, ignored") if isdbg('chanerr'); - return; - } - } - } elsif ($create) { - $parent = Route::Node->new($call); - } - $parent->lastid->{$pc} = $t; - - return $parent; -} - -# DXSpider routing entries -sub handle_92 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - my (@radd, @rdel); - - my $pcall = $_[1]; - unless ($pcall) { - dbg("PCPROT: invalid callsign string '$_[1]', ignored") if isdbg('chanerr'); - return; - } - my $t = $_[2]; - my $sort = $_[3]; - - if ($pcall eq $main::mycall) { - dbg("PCPROT: looped back, ignored") if isdbg('chanerr'); - return; - } - - if ($pcall eq $self->{call} && $self->{state} eq 'init') { - $self->state('init92'); - $self->{do_pc9x} = 1; - dbg("Do pc9x set on $pcall"); - } - unless ($self->{do_pc9x}) { - dbg("PCPROT: PC9x come in from non-PC9x node, ignored") if isdbg('chanerr'); - return; - } - - my $parent = check_pc9x_t($pcall, $t, 92, 1) || return; - my $oparent = $parent; - - $parent->do_pc9x(1); - $parent->via_pc92(1); - - if ($sort eq 'F' || $sort eq 'R') { - - # this is the route finding section - # here is where the consequences of the 'find' command - # are dealt with - - my $from = $_[4]; - my $target = $_[5]; - - if ($sort eq 'F') { - my $flag; - my $ref; - my $dxchan; - if ($ref = DXChannel::get($target)) { - $flag = 1; # we are directly connected - } else { - $ref = Route::get($target); - $dxchan = $ref->dxchan; - $flag = 2; - } - if ($ref && $flag && $dxchan) { - $self->send(pc92r($from, $target, $flag, int($dxchan->{pingave}*1000))); - return; - } - } elsif ($sort eq 'R') { - if (my $dxchan = DXChannel::get($from)) { - handle_pc92_find_reply($dxchan, $pcall, $from, $target, @_[6,7]); - } else { - my $ref = Route::get($from); - if ($ref) { - my @dxchan = grep {$_->do_pc9x} $ref->alldxchan; - if (@dxchan) { - $_->send($line) for @dxchan; - } else { - dbg("PCPROT: no return route, ignored") if isdbg('chanerr') - } - } else { - dbg("PCPROT: no return route, ignored") if isdbg('chanerr') - } - } - return; - } - } elsif ($sort eq 'A' || $sort eq 'D' || $sort eq 'C') { - - # this is the main route section - # here is where all the routes are created and destroyed - - my @ent = map {[ _decode_pc92_call($_) ]} grep {$_ && /^[0-7]/} @_[4 .. $#_]; - if (@ent) { - - # look at the first one which will always be a node of some sort - # and update any information that needs to be done. - my ($call, $is_node, $is_extnode, $here, $version, $build) = @{$ent[0]}; - if ($call && $is_node) { - if ($call eq $main::mycall) { - dbg("PCPROT: looped back on node entry, ignored") if isdbg('chanerr'); - return; - } - if ($is_extnode) { - # this is only accepted from my "self" - if (DXChannel::get($call) && $call ne $self->{call}) { - dbg("PCPROT: locally connected node config for $call from other another node $self->{call}, ignored") if isdbg('chanerr'); - return; - } - # reparent to external node (note that we must have received a 'C' or 'A' record - # from the true parent node for this external before we get one for the this node - unless ($parent = Route::Node::get($call)) { - dbg("PCPROT: no previous C or A for this external node received, ignored") if isdbg('chanerr'); - return; - } - $parent = check_pc9x_t($call, $t, 92) || return; - $parent->via_pc92(1); - } - } else { - dbg("PCPROT: must be mycall or external node as first entry, ignored") if isdbg('chanerr'); - return; - } - $parent->here(Route::here($here)); - $parent->version($version) if $version && $version > $parent->version; - $parent->build($build) if $build && $build > $parent->build; - shift @ent; - } - - # do a pass through removing any references to either locally connected nodes or mycall - my @nent; - for (@ent) { - next unless $_; - if ($_->[0] eq $main::mycall || DXChannel::get($_->[0])) { - dbg("PCPROT: $_->[0] refers to locally connected node, ignored") if isdbg('chanerr'); - next; - } - push @nent, $_; - } - - if ($sort eq 'A') { - for (@nent) { - push @radd, _add_thingy($parent, $_); - } - } elsif ($sort eq 'D') { - for (@nent) { - push @rdel, _del_thingy($parent, $_); - } - } elsif ($sort eq 'C') { - my (@nodes, @users); - - # we only reset obscounts on config records - $oparent->reset_obs; - dbg("ROUTE: reset obscount on $pcall now " . $oparent->obscount) if isdbg('route'); - if ($oparent != $parent) { - $parent->reset_obs; - dbg("ROUTE: reset obscount on $parent->{call} now " . $parent->obscount) if isdbg('route'); - } - - # - foreach my $r (@nent) { - # my ($call, $is_node, $is_extnode, $here, $version, $build) = _decode_pc92_call($_); - if ($r->[0]) { - if ($r->[1]) { - push @nodes, $r->[0]; - } else { - push @users, $r->[0]; - } - } else { - dbg("DXPROT: pc92 call entry '$_' not decoded, ignored") if isdbg('chanerr'); - } - } - - my ($dnodes, $dusers, $nnodes, $nusers) = $parent->calc_config_changes(\@nodes, \@users); - - # add users here - foreach my $r (@nent) { - my $call = $r->[0]; - if ($call) { - push @radd,_add_thingy($parent, $r) if grep $call eq $_, (@$nnodes, @$nusers); - } - } - # del users here - foreach my $r (@$dnodes) { - push @rdel,_del_thingy($parent, [$r, 1]); - } - foreach my $r (@$dusers) { - push @rdel,_del_thingy($parent, [$r, 0]); - } - } else { - dbg("PCPROT: unknown action '$sort', ignored") if isdbg('chanerr'); - return; - } - - foreach my $r (@rdel) { - next unless $r; - - $self->route_pc21($pcall, undef, $r) if $r->isa('Route::Node'); - $self->route_pc17($pcall, undef, $parent, $r) if $r->isa('Route::User'); - } - my @pc19 = grep { $_ && $_->isa('Route::Node') } @radd; - my @pc16 = grep { $_ && $_->isa('Route::User') } @radd; - unshift @pc19, $parent if $self->{state} eq 'init92' && $oparent == $parent; - $self->route_pc19($pcall, undef, @pc19) if @pc19; - $self->route_pc16($pcall, undef, $parent, @pc16) if @pc16; - } - - # broadcast it if we get here - $self->broadcast_route_pc9x($pcall, undef, $line, 0); -} - - -sub handle_93 -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - -# $self->{do_pc9x} ||= 1; - - my $pcall = $_[1]; - unless (is_callsign($pcall)) { - dbg("PCPROT: invalid callsign string '$_[1]', ignored") if isdbg('chanerr'); - return; - } - my $t = $_[2]; - my $parent = check_pc9x_t($pcall, $t, 93, 1) || return; - - my $to = $_[3]; - my $from = $_[4]; - my $via = $_[5]; - my $text = $_[6]; - my $onode = $_[7]; - $onode = $pcall if @_ <= 8; - - # will we allow it at all? - if ($censorpc) { - my @bad; - if (@bad = BadWords::check($text)) { - dbg("PCPROT: Bad words: @bad, 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 (is_callsign($to)) { - # local talks - my $dxchan; - $dxchan = DXChannel::get($main::myalias) if $to eq $main::mycall; - $dxchan = DXChannel::get($to) unless $dxchan; - if ($dxchan && $dxchan->is_user) { - $dxchan->talk($from, $to, $via, $text, $onode); - return; - } - - # convert to PC10 talks where appropriate - my $ref = Route::get($to); - if ($ref) { - my @dxchan = $ref->alldxchan; - for $dxchan (@dxchan) { - if ($dxchan->{do_pc9x}) { - $dxchan->send($line); - } else { - $dxchan->talk($from, $to, $via, $text, $onode); - } - } - return; - } - - # otherwise, drop through and allow it to be broadcast - } elsif ($to eq '*' || uc $to eq 'SYSOP' || uc $to eq 'WX') { - # announces - my $sysop = uc $to eq 'SYSOP' ? '*' : ' '; - my $wx = uc $to eq 'WX' ? '1' : '0'; - my $local = $via eq 'LOCAL' ? '*' : $via; - - $self->send_announce(1, pc12($from, $text, $local, $via, $sysop, $wx, $pcall), $from, $local, $text, $sysop, $pcall, $wx, $via eq 'LOCAL' ? $via : undef); - return if $via eq 'LOCAL'; - } else { - # chat messages to non-pc9x nodes - $self->send_chat(1, pc12($from, $text, undef, $to, undef, $pcall), $from, '*', $text, $to, $pcall, '0'); - } - $self->broadcast_route_pc9x($pcall, undef, $line, 0); -} - -# 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. -# -# NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be -# REBROADCAST!!!! -# - -sub handle_default -{ - my $self = shift; - my $pcno = shift; - my $line = shift; - my $origin = shift; - - if (eph_dup($line)) { - dbg("PCPROT: Ephemeral dup, dropped") if isdbg('chanerr'); - } else { - if ($pcno >= 90) { - my $pcall = $_[1]; - unless (is_callsign($pcall)) { - dbg("PCPROT: invalid callsign string '$_[1]', ignored") if isdbg('chanerr'); - return; - } - my $t = $_[2]; - my $parent = check_pc9x_t($pcall, $t, $pcno, 1) || return; - $self->broadcast_route_pc9x($pcall, undef, $line, 0); - } else { - unless ($self->{isolate}) { - DXChannel::broadcast_nodes($line, $self) if $line =~ /\^H\d+\^?~?$/; # send it to everyone but me - } - } - } -} - -1; ++### This module impliments the handlers for the protocal mode for a dx cluster## Copyright (c) 1998-2006 Dirk Koopman G1TLH## $Id$#package DXProt;@ISA = qw(DXChannel);use DXUtil;use DXChannel;use DXUser;use DXM;use DXProtVars;use DXCommandmode;use DXLog;use Spot;use DXProtout;use DXDebug;use Filter;use Local;use DXDb;use AnnTalk;use Geomag;use WCY;use BadWords;use DXHash;use Route;use Route::Node;use Script;use RouteDB;use strict;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 $chatimportfn $investigation_int $pc19_version $myprot_version %nodehops $baddx $badspotter $badnode $censorpc $rspfcheck $allowzero $decode_dk0wcy $send_opernam @checklist $eph_pc15_restime $pc9x_past_age $pc9x_future_age );$pc9x_past_age = 15*60; # maximum age in the past of a px9x$pc9x_future_age = 5*60; # maximum age in the future ditto# incoming talk commandssub 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; } } # remember a route to this node and also the node on which this user is RouteDB::update($_[6], $self->{call});# RouteDB::update($to, $_[6]); # convert this to a PC93 and process it as such $self->normal(pc93($to, $from, $via, $_[3], $_[6])); return; # this is all redundant but kept for now for reference # 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; } # can we see an interface to send it down? # 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 handlingsub 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]); # is the spotted callsign blank? This should really be trapped earlier but it # could break other protocol sentences. Also check for lower case characters. if ($_[2] =~ /^\s*$/) { dbg("PCPROT: blank callsign, dropped") if isdbg('chanerr'); return; } if ($_[2] =~ /[a-z]/) { dbg("PCPROT: lowercase characters, dropped") if isdbg('chanerr'); return; } # 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; } } # remember a route# RouteDB::update($_[7], $self->{call});# RouteDB::update($_[6], $_[7]); my @spot = Spot::prepare($_[1], $_[2], $d, $_[5], $nossid, $_[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(@spot[0..4,5])) { 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;}# announcessub 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(0, $line, @_[1..6]); } elsif ($_[2] eq '*' || $_[2] eq $main::mycall) { # remember a route# RouteDB::update($_[5], $self->{call});# RouteDB::update($_[1], $_[5]); # 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(0, $line, @_[1..6]); } else { $self->route($_[2], $line); }}sub handle_15{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; if (eph_dup($line, $eph_pc15_restime)) { dbg("PCPROT: Ephemeral dup, dropped") if isdbg('chanerr'); } else { unless ($self->{isolate}) { DXChannel::broadcast_nodes($line, $self) if $line =~ /\^H\d+\^?~?$/; # send it to everyone but me } }}# incoming usersub handle_16{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; # general checks my $dxchan; my $ncall = $_[1]; my $newline = "PC16^"; # dos 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 $h; $h = 1 if DXChannel::get($ncall); RouteDB::update($ncall, $self->{call}, $h); if ($h && $self->{call} ne $ncall) { dbg("PCPROT: trying to update a local node, ignored") if isdbg('chanerr'); return; } if (eph_dup($line)) { dbg("PCPROT: dup PC16 detected") if isdbg('chanerr'); return; } my $parent = Route::Node::get($ncall); if ($parent) { $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); } else { $parent = Route::Node->new($ncall); } unless ($h) { if ($parent->via_pc92) { dbg("PCPROT: non-local node controlled by PC92, ignored") if isdbg('chanerr'); return; } } 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 $h && $au; } else { my @ans = $parent->add_user($call, $flags); push @rout, @ans if $h && @ans; } # send info to all logged in thingies $self->tell_login('loginu', "$ncall: $call") if DXUser->get_current($ncall)->is_local_node; $self->tell_buddies('loginb', $call, $ncall); # 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; } if (@rout) { $self->route_pc16($origin, $line, $parent, @rout) if @rout;# $self->route_pc92a($main::mycall, undef, $parent, @rout) if $h && $self->{state} eq 'normal'; }}# remove a usersub 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; } RouteDB::delete($ncall, $self->{call}); 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 = DXChannel::get($ncall); if ($dxchan && $dxchan ne $self) { dbg("PCPROT: PC17 from $self->{call} trying to alter locally connected $ncall, ignored!") if isdbg('chanerr'); return; } unless ($dxchan) { if ($parent->via_pc92) { dbg("PCPROT: non-local node controlled by PC92, ignored") if isdbg('chanerr'); return; } } if (DXChannel::get($ucall)) { dbg("PCPROT: trying do disconnect local user, ignored") if isdbg('chanerr'); return; } # input filter if required and then remove user if present# return unless $self->in_filter_route($parent); $parent->del_user($uref); # send info to all logged in thingies $self->tell_login('logoutu', "$ncall: $ucall") if DXUser->get_current($ncall)->is_local_node; $self->tell_buddies('logoutb', $ucall, $ncall); if (eph_dup($line)) { dbg("PCPROT: dup PC17 detected") if isdbg('chanerr'); return; } $self->route_pc17($origin, $line, $parent, $uref);# $self->route_pc92d($main::mycall, undef, $parent, $uref) if $dxchan;}# link requestsub 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'); } $self->{handle_xml}++ if DXXml::available() && $_[1] =~ /\bxml/; if ($_[1] =~ /\bpc9x/) { $self->{do_pc9x} = 1; dbg("Do px9x set on $self->{call}"); } } 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());}sub check_add_node{ my $call = shift; # 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->priv(1); # I have relented and defaulted nodes $user->lockout(1); $user->homenode($call); $user->node($call); } $user->sort('A') unless $user->is_node; return $user;}# incoming cluster listsub handle_19{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; my $i; my $newline = "PC19^"; # new routing list my (@rout, @pc92out); # 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; } my $h; # parse the PC19 # # We are making a major change from now on. We are only going to accept # PC19s from directly connected nodes. This means that we are probably # going to throw away most of the data that we are being sent. # # The justification for this is that most of it is wrong or out of date # anyway. # # From now on we are only going to believe PC92 data and locally connected # non-pc92 nodes. # 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 unless $ver && $ver =~ /^\d+$/; 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 $h = 0; my $dxchan = DXChannel::get($call); if ($dxchan) { if ($dxchan == $self) { $h = 1; } else { dbg("PCPROT: PC19 from $self->{call} trying to alter wrong locally connected $call, ignored!") if isdbg('chanerr'); next; } } my $user = check_add_node($call);# if (eph_dup($genline)) {# dbg("PCPROT: dup PC19 for $call detected") if isdbg('chanerr');# next;# } RouteDB::update($call, $self->{call}, $dxchan ? 1 : undef); unless ($h) { if ($parent->via_pc92) { dbg("PCPROT: non-local node controlled by PC92, ignored") if isdbg('chanerr'); next; } } 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; } else { 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; push @pc92out, $r if $h; } else { next; } } } # 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; } # we are not automatically sending out PC19s, we send out a composite PC21,PC19 instead # but remember there will only be one (pair) these because any extras will be # thrown away. if (@rout) {# $self->route_pc21($self->{call}, $line, @rout); $self->route_pc19($self->{call}, $line, @rout); } if (@pc92out) { $self->route_pc92a($main::mycall, $line, $main::routeroot, @pc92out) if $self->{state} eq 'normal'; }}sub send_delayed_pc92{ my $self = shift; # send out new PC92 config to everyone else my $line = gen_my_pc92_config($main::me); $self->broadcast_route_pc9x($main::mycall, undef, $line, 0); # if this is an external node then send out the external config unless ($self->{do_pc9x}) { $line = gen_my_pc92_config(Route::Node::get($self->{call})); $self->broadcast_route_pc9x($main::mycall, undef, $line, 0); }}# send local configurationsub handle_20{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; if ($self->{do_pc9x} && $self->{state} ne 'init92') { dbg("PCPROT: disconnecting because login call not sent in any pc92") if isdbg('chanerr'); $self->send("**** You logged in with $self->{call} but that is NOT your \$mycall"); $self->disconnect; return; } $self->send_local_config(); $self->send(pc22()); $self->state('normal'); $self->{lastping} = 0; $self->send_delayed_pc92;}# delete a cluster from the list## This should never occur for directly connected nodes.#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 ignore it if ($call eq $self->call) { dbg("PCPROT: self referencing PC21 from $self->{call}"); return; } RouteDB::delete($call, $self->{call}); my $parent = Route::Node::get($self->{call}); unless ($parent) { dbg("PCPROT: my parent $self->{call} has disappeared"); $self->disconnect; return; } my @rout; if ($call ne $main::mycall) { # don't allow malicious buggers to disconnect me! my $node = Route::Node::get($call); if ($node) { if ($node->via_pc92) { dbg("PCPROT: controlled by PC92, ignored") if isdbg('chanerr'); return; } 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, force a PC21 if it is local push @rout, $node->del($parent); push @rout, $call if $dxchan && @rout == 0; } } else { dbg("PCPROT: I WILL _NOT_ be disconnected!") if isdbg('chanerr'); return; } if (eph_dup($line)) { dbg("PCPROT: dup PC21 detected") if isdbg('chanerr'); return; } if (@rout) { $self->route_pc21($origin, $line, @rout);# $self->route_pc92d($main::mycall, $line, $main::routeroot, @rout); }}sub handle_22{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; if ($self->{do_pc9x}) { if ($self->{state} ne 'init92') { dbg("PCPROT: disconnecting because login call not sent in any pc92") if isdbg('chanerr'); $self->send("**** You logged in with $self->{call} but that is NOT your \$mycall"); $self->disconnect; return; } } $self->{lastping} = 0; $self->state('normal'); $self->send_delayed_pc92;}# WWV infosub 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; } } # only do a rspf check on PC23 (not 27) if ($pcno == 23) { 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; } # global wwv filtering on INPUT my @dxcc = ((Prefix::cty_data($_[7]))[0..2], (Prefix::cty_data($_[8]))[0..2]); if ($self->{inwwvfilter}) { my ($filter, $hops) = $self->{inwwvfilter}->it(@_[7,8], $origin, @dxcc); unless ($filter) { dbg("PCPROT: Rejected by input wwv filter") if isdbg('chanerr'); return; } } $_[7] =~ s/-\d+$//o; # remove spotter's ssid if (Geomag::dup($d,$sfi,$k,$i,$_[6],$_[7])) { dbg("PCPROT: Dup WWV Spot ignored\n") if isdbg('chanerr'); return; } # note this only takes the first one it gets 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 statussub 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 requestsub 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 handlingsub 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 repliessub 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 stuffsub handle_37{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; if ($_[1] eq $main::mycall) { no strict 'refs'; my $sub = "DXDb::handle_$pcno"; &$sub($self, @_); } else { $self->route($_[1], $line) unless $self->is_clx; }}# node connected list from neighboursub handle_38{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift;}# incoming disconnectsub 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 infosub handle_41{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; my $call = $_[1]; my $sort = $_[2]; my $val = $_[3]; my $l = "PC41^$call^$sort"; 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 ($val eq $sort || $val =~ /^\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 ($sort == 1) { if (($val =~ /spotter/i || $val =~ /self/i) && $user->name && $user->name ne $val) { dbg("PCPROT: invalid name") if isdbg('chanerr'); if ($main::mycall eq 'GB7DJK' || $main::mycall eq 'GB7BAA' || $main::mycall eq 'WR3D') { DXChannel::broadcast_nodes(pc41($_[1], 1, $user->name)); # send it to everyone including me } return; } $user->name($val); } elsif ($sort == 2) { $user->qth($val); } elsif ($sort == 3) { if (is_latlong($val)) { my ($lat, $long) = DXBearing::stoll($val); $user->lat($lat) if $lat; $user->long($long) if $long; $user->qra(DXBearing::lltoqra($lat, $long)) unless $user->qra; } else { dbg('PCPROT: not a valid lat/long') if isdbg('chanerr'); return; } } elsif ($sort == 4) { $user->homenode($val); } elsif ($sort == 5) { if (is_qra(uc $val)) { my ($lat, $long) = DXBearing::qratoll(uc $val); $user->lat($lat) if $lat && !$user->lat; $user->long($long) if $long && !$user->long; $user->qra(uc $val); } 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, $sort, $val, $_[4]);}sub handle_42 {goto &handle_28}# databasesub 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 databasesub handle_49{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; 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; }}# keep alive/user listsub handle_50{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; my $call = $_[1]; RouteDB::update($call, $self->{call}); my $node = Route::Node::get($call); if ($node) { return unless $node->call eq $self->{call}; $node->usercount($_[2]); # input filter if required return unless $self->in_filter_route($node); $self->route_pc50($origin, $line, $node, $_[2], $_[3]) unless eph_dup($line); }}# incoming ping requests/answerssub handle_51{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; my $to = $_[1]; my $from = $_[2]; my $flag = $_[3]; # is it for us? if ($to eq $main::mycall) { if ($flag == 1) { $self->send(pc51($from, $to, '0')); } else { DXXml::Ping::handle_ping_reply($self, $from); } } else { RouteDB::update($from, $self->{call}); if (eph_dup($line)) { dbg("PCPROT: dup PC51 detected") if isdbg('chanerr'); return; } # route down an appropriate thingy $self->route($to, $line); }}# dunno but route itsub 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); }}# WCY broadcastssub 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; } my $wcy = WCY::update($d, @_[2..12]); my $rep; eval { $rep = Local::wcy($self, @_[1..12]); }; # dbg("Local::wcy error $@") if isdbg('local') if $@; return if $rep; # broadcast to the eager world send_wcy_spot($self, $line, $d, @_[2..12]);}# remote commands (incoming)sub handle_84{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; $self->process_rcmd($_[1], $_[2], $_[3], $_[4]);}# remote command repliessub handle_85{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; $self->process_rcmd_reply($_[1], $_[2], $_[3], $_[4]);}# decode a pc92 call: flag call : version : buildsub _decode_pc92_call{ my $icall = shift; my @part = split /:/, $icall; my ($flag, $call) = unpack "A A*", $part[0]; return () unless defined $flag && $flag ge '0' && $flag le '7'; return () unless $call && is_callsign($call); my $is_node = $flag & 4; my $is_extnode = $flag & 2; my $here = $flag & 1; return ($call, $is_node, $is_extnode, $here, $part[1], $part[2]);}# decode a pc92 call: flag call : version : buildsub _encode_pc92_call{ my $ref = shift; # plain call or value return $ref unless ref $ref; my $ext = shift; my $flag = 0; my $call = $ref->call; my $extra = ''; $flag |= $ref->here ? 1 : 0; if ($ref->isa('Route::Node') || $ref->isa('DXProt')) { $flag |= 4; my $dxchan = DXChannel::get($call); $flag |= 2 if $call ne $main::mycall && $dxchan && !$dxchan->{do_pc9x}; if ($ext) { if ($ref->version) { my $version = $ref->version || 1.0; $version = $version * 100 + 5300 if $version < 50; $extra .= ":" . $version; } } } return "$flag$call$extra";}sub _add_thingy{ my $parent = shift; my $s = shift; my ($call, $is_node, $is_extnode, $here, $version, $build) = @$s; my @rout; if ($call) { if ($is_node) { dbg("ROUTE: added node $call to " . $parent->call) if isdbg('routelow'); @rout = $parent->add($call, $version, Route::here($here)); } else { dbg("ROUTE: added user $call to " . $parent->call) if isdbg('routelow'); @rout = $parent->add_user($call, Route::here($here)); } } return @rout;}sub _del_thingy{ my $parent = shift; my $s = shift; my ($call, $is_node, $is_extnode, $here, $version, $build) = @$s; my @rout; if ($call) { if ($is_node) { my $nref = Route::Node::get($call); dbg("ROUTE: deleting node $call from " . $parent->call) if isdbg('routelow'); @rout = $nref->del($parent) if $nref; } else { my $uref = Route::User::get($call); dbg("ROUTE: deleting user $call from " . $parent->call) if isdbg('routelow'); @rout = $parent->del_user($uref) if $uref; } } return @rout;}my $_last_time;my $_last_occurs;sub gen_pc9x_t{ if (!$_last_time || $_last_time != $main::systime) { $_last_time = $main::systime; $_last_occurs = 0; return $_last_time - $main::systime_daystart; } else { $_last_occurs++; return sprintf "%d.%02d", $_last_time - $main::systime_daystart, $_last_occurs; }}sub check_pc9x_t{ my $call = shift; my $t = shift; my $pc = shift; my $create = shift; my $parent = ref $call ? $call : Route::Node::get($call); if ($parent) { # we only do this for external calls whose routing table # record come and go. The reference for mycall is permanent # and not that frequently used, it also never times out, so # the id on it is completely unreliable. Besides, only commands # originating on this box will go through this code... if ($parent->call ne $main::mycall) { my $lastid = $parent->lastid->{$pc} || 0; if ($t < $lastid) { if (my $d = $lastid-86400+$t > $pc9x_past_age) { dbg("PCPROT: $call id $t <= $lastid, ignored") if isdbg('chanerr'); return; } } if ($lastid == $t) { dbg("PCPROT: dup id on $call = $lastid, ignored") if isdbg('chanerr'); return; } } } elsif ($create) { $parent = Route::Node->new($call); } $parent->lastid->{$pc} = $t; return $parent;}# DXSpider routing entriessub handle_92{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; my (@radd, @rdel); my $pcall = $_[1]; unless ($pcall) { dbg("PCPROT: invalid callsign string '$_[1]', ignored") if isdbg('chanerr'); return; } my $t = $_[2]; my $sort = $_[3]; if ($pcall eq $main::mycall) { dbg("PCPROT: looped back, ignored") if isdbg('chanerr'); return; } if ($pcall eq $self->{call} && $self->{state} eq 'init') { $self->state('init92'); $self->{do_pc9x} = 1; dbg("Do pc9x set on $pcall"); } unless ($self->{do_pc9x}) { dbg("PCPROT: PC9x come in from non-PC9x node, ignored") if isdbg('chanerr'); return; } my $parent = check_pc9x_t($pcall, $t, 92, 1) || return; my $oparent = $parent; $parent->do_pc9x(1); $parent->via_pc92(1); if ($sort eq 'F' || $sort eq 'R') { # this is the route finding section # here is where the consequences of the 'find' command # are dealt with my $from = $_[4]; my $target = $_[5]; if ($sort eq 'F') { my $flag; my $ref; my $dxchan; if ($ref = DXChannel::get($target)) { $flag = 1; # we are directly connected } else { $ref = Route::get($target); $dxchan = $ref->dxchan; $flag = 2; } if ($ref && $flag && $dxchan) { $self->send(pc92r($from, $target, $flag, int($dxchan->{pingave}*1000))); return; } } elsif ($sort eq 'R') { if (my $dxchan = DXChannel::get($from)) { handle_pc92_find_reply($dxchan, $pcall, $from, $target, @_[6,7]); } else { my $ref = Route::get($from); if ($ref) { my @dxchan = grep {$_->do_pc9x} $ref->alldxchan; if (@dxchan) { $_->send($line) for @dxchan; } else { dbg("PCPROT: no return route, ignored") if isdbg('chanerr') } } else { dbg("PCPROT: no return route, ignored") if isdbg('chanerr') } } return; } } elsif ($sort eq 'A' || $sort eq 'D' || $sort eq 'C') { # this is the main route section # here is where all the routes are created and destroyed my @ent = map {[ _decode_pc92_call($_) ]} grep {$_ && /^[0-7]/} @_[4 .. $#_]; if (@ent) { # look at the first one which will always be a node of some sort # and update any information that needs to be done. my ($call, $is_node, $is_extnode, $here, $version, $build) = @{$ent[0]}; if ($call && $is_node) { if ($call eq $main::mycall) { dbg("PCPROT: looped back on node entry, ignored") if isdbg('chanerr'); return; } if ($is_extnode) { # this is only accepted from my "self" if (DXChannel::get($call) && $call ne $self->{call}) { dbg("PCPROT: locally connected node config for $call from other another node $self->{call}, ignored") if isdbg('chanerr'); return; } # reparent to external node (note that we must have received a 'C' or 'A' record # from the true parent node for this external before we get one for the this node unless ($parent = Route::Node::get($call)) { dbg("PCPROT: no previous C or A for this external node received, ignored") if isdbg('chanerr'); return; } $parent = check_pc9x_t($call, $t, 92) || return; $parent->via_pc92(1); } } else { dbg("PCPROT: must be mycall or external node as first entry, ignored") if isdbg('chanerr'); return; } $parent->here(Route::here($here)); $parent->version($version) if $version && $version > $parent->version; $parent->build($build) if $build && $build > $parent->build; shift @ent; } # do a pass through removing any references to either locally connected nodes or mycall my @nent; for (@ent) { next unless $_; if ($_->[0] eq $main::mycall || DXChannel::get($_->[0])) { dbg("PCPROT: $_->[0] refers to locally connected node, ignored") if isdbg('chanerr'); next; } push @nent, $_; } if ($sort eq 'A') { for (@nent) { push @radd, _add_thingy($parent, $_); } } elsif ($sort eq 'D') { for (@nent) { push @rdel, _del_thingy($parent, $_); } } elsif ($sort eq 'C') { my (@nodes, @users); # we only reset obscounts on config records $oparent->reset_obs; dbg("ROUTE: reset obscount on $pcall now " . $oparent->obscount) if isdbg('route'); if ($oparent != $parent) { $parent->reset_obs; dbg("ROUTE: reset obscount on $parent->{call} now " . $parent->obscount) if isdbg('route'); } # foreach my $r (@nent) { # my ($call, $is_node, $is_extnode, $here, $version, $build) = _decode_pc92_call($_); if ($r->[0]) { if ($r->[1]) { push @nodes, $r->[0]; } else { push @users, $r->[0]; } } else { dbg("DXPROT: pc92 call entry '$_' not decoded, ignored") if isdbg('chanerr'); } } my ($dnodes, $dusers, $nnodes, $nusers) = $parent->calc_config_changes(\@nodes, \@users); # add users here foreach my $r (@nent) { my $call = $r->[0]; if ($call) { push @radd,_add_thingy($parent, $r) if grep $call eq $_, (@$nnodes, @$nusers); } } # del users here foreach my $r (@$dnodes) { push @rdel,_del_thingy($parent, [$r, 1]); } foreach my $r (@$dusers) { push @rdel,_del_thingy($parent, [$r, 0]); } } else { dbg("PCPROT: unknown action '$sort', ignored") if isdbg('chanerr'); return; } foreach my $r (@rdel) { next unless $r; $self->route_pc21($pcall, undef, $r) if $r->isa('Route::Node'); $self->route_pc17($pcall, undef, $parent, $r) if $r->isa('Route::User'); } my @pc19 = grep { $_ && $_->isa('Route::Node') } @radd; my @pc16 = grep { $_ && $_->isa('Route::User') } @radd; unshift @pc19, $parent if $self->{state} eq 'init92' && $oparent == $parent; $self->route_pc19($pcall, undef, @pc19) if @pc19; $self->route_pc16($pcall, undef, $parent, @pc16) if @pc16; } # broadcast it if we get here $self->broadcast_route_pc9x($pcall, undef, $line, 0);}sub handle_93{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift;# $self->{do_pc9x} ||= 1; my $pcall = $_[1]; unless (is_callsign($pcall)) { dbg("PCPROT: invalid callsign string '$_[1]', ignored") if isdbg('chanerr'); return; } my $t = $_[2]; my $parent = check_pc9x_t($pcall, $t, 93, 1) || return; my $to = $_[3]; my $from = $_[4]; my $via = $_[5]; my $text = $_[6]; my $onode = $_[7]; $onode = $pcall if @_ <= 8; # will we allow it at all? if ($censorpc) { my @bad; if (@bad = BadWords::check($text)) { dbg("PCPROT: Bad words: @bad, 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 (is_callsign($to)) { # local talks my $dxchan; $dxchan = DXChannel::get($main::myalias) if $to eq $main::mycall; $dxchan = DXChannel::get($to) unless $dxchan; if ($dxchan && $dxchan->is_user) { $dxchan->talk($from, $to, $via, $text, $onode); return; } # convert to PC10 talks where appropriate my $ref = Route::get($to); if ($ref) { my @dxchan = $ref->alldxchan; for $dxchan (@dxchan) { if ($dxchan->{do_pc9x}) { $dxchan->send($line); } else { $dxchan->talk($from, $to, $via, $text, $onode); } } return; } # otherwise, drop through and allow it to be broadcast } elsif ($to eq '*' || uc $to eq 'SYSOP' || uc $to eq 'WX') { # announces my $sysop = uc $to eq 'SYSOP' ? '*' : ' '; my $wx = uc $to eq 'WX' ? '1' : '0'; my $local = $via eq 'LOCAL' ? '*' : $via; $self->send_announce(1, pc12($from, $text, $local, $via, $sysop, $wx, $pcall), $from, $local, $text, $sysop, $pcall, $wx, $via eq 'LOCAL' ? $via : undef); return if $via eq 'LOCAL'; } else { # chat messages to non-pc9x nodes $self->send_chat(1, pc12($from, $text, undef, $to, undef, $pcall), $from, '*', $text, $to, $pcall, '0'); } $self->broadcast_route_pc9x($pcall, undef, $line, 0);}# 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.## NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be# REBROADCAST!!!!#sub handle_default{ my $self = shift; my $pcno = shift; my $line = shift; my $origin = shift; if (eph_dup($line)) { dbg("PCPROT: Ephemeral dup, dropped") if isdbg('chanerr'); } else { if ($pcno >= 90) { my $pcall = $_[1]; unless (is_callsign($pcall)) { dbg("PCPROT: invalid callsign string '$_[1]', ignored") if isdbg('chanerr'); return; } my $t = $_[2]; my $parent = check_pc9x_t($pcall, $t, $pcno, 1) || return; $self->broadcast_route_pc9x($pcall, undef, $line, 0); } else { unless ($self->{isolate}) { DXChannel::broadcast_nodes($line, $self) if $line =~ /\^H\d+\^?~?$/; # send it to everyone but me } } }}1; diff --cc perl/DXProtVars.pm index a5f6bc43,a5f6bc43..9f839b23 --- a/perl/DXProtVars.pm +++ b/perl/DXProtVars.pm @@@ -1,50 -1,50 +1,1 @@@ --# --# --# These are various values used by the AK1A protocol stack --# --# Change these at your peril (or if you know what you are doing)! --# --# Copyright (c) 1998 - Dirk Koopman G1TLH --# --# $Id$ --# -- --package DXProt; -- --# the interval between pc50s (in seconds) --$pc50_interval = 14*60; -- --# the version of DX cluster (tm) software I am masquerading as --$myprot_version = 5300; -- --# default hopcount to use --$def_hopcount = 30; -- --# some variable hop counts based on message type --%hopcount = ( -- 11 => 25, -- 16 => 25, -- 17 => 25, -- 19 => 25, -- 21 => 25, --); -- --# list of nodes we don't accept dx from --@nodx_node = ( -- --); -- --# list of nodes we don't accept announces from --@noann_node = ( -- --); -- --# list of node we don't accept wwvs from --@nowwv_node = ( -- --); -- --# send out for/opernams for callsigns sending dx spots who haven't got qra locators --$send_opernam = 0; -- --1; ++### These are various values used by the AK1A protocol stack## Change these at your peril (or if you know what you are doing)!## Copyright (c) 1998 - Dirk Koopman G1TLH## $Id$#package DXProt;# the interval between pc50s (in seconds)$pc50_interval = 14*60;# the version of DX cluster (tm) software I am masquerading as$myprot_version = 5300;# default hopcount to use$def_hopcount = 30;# some variable hop counts based on message type%hopcount = ( 11 => 25, 16 => 25, 17 => 25, 19 => 25, 21 => 25,);# list of nodes we don't accept dx from@nodx_node = ();# list of nodes we don't accept announces from@noann_node = ();# list of node we don't accept wwvs from@nowwv_node = ();# send out for/opernams for callsigns sending dx spots who haven't got qra locators$send_opernam = 0;1; diff --cc perl/DXProtout.pm index 82905dad,e00e1d72..27b7a4c9 --- a/perl/DXProtout.pm +++ b/perl/DXProtout.pm @@@ -1,380 -1,455 +1,1 @@@ --#!/usr/bin/perl --# --# This module impliments the outgoing PCxx generation routines --# --# These are all the namespace of DXProt and are separated for "clarity" --# --# Copyright (c) 1998 Dirk Koopman G1TLH --# --# $Id$ --# -- --package DXProt; -- --@ISA = qw(DXProt DXChannel); -- --use DXUtil; --use DXM; --use DXDebug; -- --use strict; -- --use vars qw($sentencelth); -- --$sentencelth = 180; -- --# --# All the PCxx generation routines --# -- --# create a talk string ($from, $to, $via, $text) --sub pc10 --{ -- my ($from, $to, $via, $text, $origin) = @_; -- my ($user1, $user2); - if ($via && $via ne $to) { - if ($via && $via ne $to && $via ne '*') { -- $user1 = $via; -- $user2 = $to; -- } else { -- $user2 = ' '; -- $user1 = $to; -- } -- $origin ||= $main::mycall; -- $text = unpad($text); -- $text = ' ' unless $text && length $text > 0; -- $text =~ s/\^/%5E/g; -- return "PC10^$from^$user1^$text^*^$user2^$origin^~"; --} -- --# create a dx message (call, freq, dxcall, text) --sub pc11 --{ -- my ($mycall, $freq, $dxcall, $text) = @_; -- my $hops = get_hops(11); -- my $t = time; -- $text = ' ' if !$text; -- $text =~ s/\^/%5E/g; -- return sprintf "PC11^%.1f^$dxcall^%s^%s^$text^$mycall^$main::mycall^$hops^~", $freq, cldate($t), ztime($t); --} -- --# create an announce message --sub pc12 --{ -- my ($call, $text, $tonode, $sysop, $wx, $origin) = @_; -- my $hops = get_hops(12); -- $text ||= ' '; -- $text =~ s/\^/%5E/g; -- $tonode ||= '*'; -- $sysop ||= ' '; -- $wx ||= '0'; -- $origin ||= $main::mycall; -- return "PC12^$call^$tonode^$text^$sysop^$origin^$wx^$hops^~"; --} -- --# --# add one or more users (I am expecting references that have 'call', --# 'conf' & 'here' method) --# --# this will create a list of PC16 with up pc16_max_users in each --# called $self->pc16(..) --# --sub pc16 --{ -- my $node = shift; -- my $ncall = $node->call; -- my @out; -- -- my $s = ""; -- for (@_) { -- next unless $_; -- my $ref = $_; -- my $str = sprintf "^%s %s %d", $ref->call, $ref->conf ? '*' : '-', $ref->here; -- if (length($s) + length($str) > $sentencelth) { -- push @out, "PC16^$ncall" . $s . sprintf "^%s^", get_hops(16); -- $s = ""; -- } -- $s .= $str; -- } -- push @out, "PC16^$ncall" . $s . sprintf "^%s^", get_hops(16); -- return @out; --} -- --# remove a local user --sub pc17 --{ -- my @out; -- while (@_) { -- my $node = shift; -- my $ref = shift; -- my $hops = get_hops(17); -- my $ncall = $node->call; -- my $ucall = $ref->call; -- push @out, "PC17^$ucall^$ncall^$hops^"; -- } -- return @out; --} -- --# Request init string --sub pc18 --{ - my $flags = ""; - my $flags = " pc9x"; -- $flags .= " xml" if DXXml::available(); -- return "PC18^DXSpider Version: $main::version Build: $main::build$flags^$DXProt::myprot_version^"; --} -- --# --# add one or more nodes --# --sub pc19 --{ -- my @out; -- my @in; -- -- my $s = ""; -- for (@_) { -- next unless $_; -- my $ref = $_; -- my $call = $ref->call; -- my $here = $ref->here; -- my $conf = $ref->conf; -- my $version = $ref->version; -- my $str = "^$here^$call^$conf^$version"; -- if (length($s) + length($str) > $sentencelth) { -- push @out, "PC19" . $s . sprintf "^%s^", get_hops(19); -- $s = ""; -- } -- $s .= $str; -- } -- push @out, "PC19" . $s . sprintf "^%s^", get_hops(19); -- return @out; --} -- --# end of Rinit phase --sub pc20 --{ -- return 'PC20^'; --} -- --# delete a node --sub pc21 --{ -- my @out; -- while (@_) { -- my $node = shift; -- my $hops = get_hops(21); -- my $call = $node->call; -- push @out, "PC21^$call^Gone^$hops^"; -- } -- return @out; --} -- --# end of init phase --sub pc22 --{ -- return 'PC22^'; --} -- --# here status --sub pc24 --{ -- my $self = shift; -- my $call = $self->call; -- my $flag = $self->here ? '1' : '0'; -- my $hops = shift || get_hops(24); -- -- return "PC24^$call^$flag^$hops^"; --} -- -- --# create a merged dx message (freq, dxcall, t, text, spotter, orig-node) --sub pc26 --{ -- my ($freq, $dxcall, $t, $text, $spotter, $orignode) = @_; -- $text = ' ' unless $text; -- $orignode = $main::mycall unless $orignode; -- return sprintf "PC26^%.1f^$dxcall^%s^%s^$text^$spotter^$orignode^ ^~", $freq, cldate($t), ztime($t); --} -- --# create a merged WWV spot (logger, t, sfi, a, k, forecast, orig-node) --sub pc27 --{ -- my ($logger, $t, $sfi, $a, $k, $forecast, $orignode) = @_; -- return sprintf "PC27^%s^%-2.2s^$sfi^$a^$k^$forecast^$logger^$orignode^ ^~", cldate($t), ztime($t); --} -- --# message start (fromnode, tonode, to, from, t, private, subject, origin) --sub pc28 --{ -- my ($tonode, $fromnode, $to, $from, $t, $private, $subject, $origin, $rr) = @_; -- my $date = cldate($t); -- my $time = ztime($t); -- $private = $private ? '1' : '0'; -- $rr = $rr ? '1' : '0'; -- $subject ||= ' '; -- return "PC28^$tonode^$fromnode^$to^$from^$date^$time^$private^$subject^ ^5^$rr^ ^$origin^~"; --} -- --# message text (from and to node same way round as pc29) --sub pc29 --{ -- my ($fromnode, $tonode, $stream, $text) = @_; -- $text = ' ' unless defined $text && length $text > 0; -- $text =~ s/\^/%5E/og; # remove ^ -- return "PC29^$fromnode^$tonode^$stream^$text^~"; --} -- --# subject acknowledge (will have to and from node reversed to pc28) --sub pc30 --{ -- my ($fromnode, $tonode, $stream) = @_; -- return "PC30^$fromnode^$tonode^$stream^"; --} -- --# acknowledge this tranche of lines (to and from nodes reversed to pc29 and pc28 --sub pc31 --{ -- my ($fromnode, $tonode, $stream) = @_; -- return "PC31^$fromnode^$tonode^$stream^"; --} -- --# end of message from the sending end (pc28 node order) --sub pc32 --{ -- my ($fromnode, $tonode, $stream) = @_; -- return "PC32^$fromnode^$tonode^$stream^"; --} -- --# acknowledge end of message from receiving end (opposite pc28 node order) --sub pc33 --{ -- my ($fromnode, $tonode, $stream) = @_; -- return "PC33^$fromnode^$tonode^$stream^"; --} -- --# remote cmd send --sub pc34 --{ -- my($fromnode, $tonode, $msg) = @_; -- return "PC34^$tonode^$fromnode^$msg^~"; --} -- --# remote cmd reply --sub pc35 --{ -- my($fromnode, $tonode, $msg) = @_; -- return "PC35^$tonode^$fromnode^$msg^~"; --} -- --# send all the DX clusters I reckon are connected --sub pc38 --{ -- return join '^', "PC38", map {$_->call} Route::Node::get_all(); --} -- --# tell the local node to discconnect --sub pc39 --{ -- my ($call, $reason) = @_; -- my $hops = get_hops(39); -- $reason = "Gone." if !$reason; -- return "PC39^$call^$reason^$hops^"; --} -- --# cue up bulletin or file for transfer --sub pc40 --{ -- my ($to, $from, $fn, $bull) = @_; -- $bull = $bull ? '1' : '0'; -- return "PC40^$to^$from^$fn^$bull^5^"; --} -- --# user info --sub pc41 --{ -- my $call = shift; -- $call = shift if ref $call; -- -- my $sort = shift || '0'; -- my $info = shift || ' '; -- my $hops = shift || get_hops(41); -- return "PC41^$call^$sort^$info^$hops^~"; --} -- --# abort message --sub pc42 --{ -- my ($fromnode, $tonode, $stream) = @_; -- return "PC42^$fromnode^$tonode^$stream^"; --} -- --# remote db request --sub pc44 --{ -- my ($fromnode, $tonode, $stream, $db, $req, $call) = @_; -- $db = uc $db; -- return "PC44^$tonode^$fromnode^$stream^$db^$req^$call^"; --} -- --# remote db data --sub pc45 --{ -- my ($fromnode, $tonode, $stream, $data) = @_; -- return "PC45^$tonode^$fromnode^$stream^$data^"; --} -- --# remote db data complete --sub pc46 --{ -- my ($fromnode, $tonode, $stream) = @_; -- return "PC46^$tonode^$fromnode^$stream^"; --} -- --# bull delete --sub pc49 --{ -- my ($from, $subject) = @_; -- my $hops = get_hops(49); -- return "PC49^$from^$subject^$hops^~"; --} -- --# periodic update of users, plus keep link alive device (always H99) --sub pc50 --{ -- my $self = shift; -- my $call = $self->call; -- my $n = shift || '0'; -- my $hops = shift || 'H99'; -- return "PC50^$call^$n^$hops^"; --} -- --# generate pings --sub pc51 --{ -- my ($to, $from, $val) = @_; -- return "PC51^$to^$from^$val^"; --} -- --# clx remote cmd send --sub pc84 --{ -- my($fromnode, $tonode, $call, $msg) = @_; -- return "PC84^$tonode^$fromnode^$call^$msg^~"; --} -- --# clx remote cmd reply --sub pc85 --{ -- my($fromnode, $tonode, $call, $msg) = @_; -- return "PC85^$tonode^$fromnode^$call^$msg^~"; --} -- - # spider route broadcast - sub pc90 -# spider route broadcasts -# - - -sub _gen_pc92 -{ - my $sort = shift; - my $ext = shift; - my $s = "PC92^$main::mycall^" . gen_pc9x_t() . "^$sort"; - for (@_) { - $s .= "^" . _encode_pc92_call($_, $ext); - } - return $s . '^H99^'; -} - -sub gen_pc92_with_time -{ - my $call = shift; - my $sort = shift; - my $t = shift; - my $ext = 1; - my $s = "PC92^$call^$t^$sort"; - for (@_) { - $s .= "^" . _encode_pc92_call($_, $ext); - } - return $s . '^H99^'; -} - -# add a local one -sub pc92a -{ - return _gen_pc92('A', 0, @_); -} - -# delete a local one -sub pc92d -{ - return _gen_pc92('D', 0, @_); -} - -# send a config -sub pc92c -{ - return _gen_pc92('C', 1, @_); -} - -# send a 'find' message -sub pc92f -{ - my $target = shift; - my $from = shift; - return "PC92^$main::mycall^" . gen_pc9x_t() . "^F^$from^$target^H99^" -} - -# send a 'reply' message -sub pc92r -{ - my $to = shift; - my $target = shift; - my $flag = shift; - my $ms = shift; - return "PC92^$main::mycall^" . gen_pc9x_t() . "^R^$to^$target^$flag^$ms^H99^" -} - -sub pc93 --{ - my $to = shift; # *, callsign, chat group name, sysop - my $from = shift; # from user callsign - my $via = shift || '*'; # *, node call - my $line = shift; # the text - my $origin = shift; # this will be present on proxying from PC10 - - $line = unpad($line); - $line =~ s/\^/\\5E/g; # remove any ^ characters - my $s = "PC93^$main::mycall^" . gen_pc9x_t() . "^$to^$from^$via^$line"; - $s .= "^$origin" if $origin; - $s .= "^H99^"; - return $s; --} -- --1; --__END__ -- -- -- ++#!/usr/bin/perl## This module impliments the outgoing PCxx generation routines## These are all the namespace of DXProt and are separated for "clarity"## Copyright (c) 1998 Dirk Koopman G1TLH## $Id$#package DXProt;@ISA = qw(DXProt DXChannel);use DXUtil;use DXM;use DXDebug;use strict;use vars qw($sentencelth);$sentencelth = 180;## All the PCxx generation routines## create a talk string ($from, $to, $via, $text)sub pc10{ my ($from, $to, $via, $text, $origin) = @_; my ($user1, $user2); if ($via && $via ne $to && $via ne '*') { $user1 = $via; $user2 = $to; } else { $user2 = ' '; $user1 = $to; } $origin ||= $main::mycall; $text = unpad($text); $text = ' ' unless $text && length $text > 0; $text =~ s/\^/%5E/g; return "PC10^$from^$user1^$text^*^$user2^$origin^~";}# create a dx message (call, freq, dxcall, text)sub pc11{ my ($mycall, $freq, $dxcall, $text) = @_; my $hops = get_hops(11); my $t = time; $text = ' ' if !$text; $text =~ s/\^/%5E/g; return sprintf "PC11^%.1f^$dxcall^%s^%s^$text^$mycall^$main::mycall^$hops^~", $freq, cldate($t), ztime($t);}# create an announce messagesub pc12{ my ($call, $text, $tonode, $sysop, $wx, $origin) = @_; my $hops = get_hops(12); $text ||= ' '; $text =~ s/\^/%5E/g; $tonode ||= '*'; $sysop ||= ' '; $wx ||= '0'; $origin ||= $main::mycall; return "PC12^$call^$tonode^$text^$sysop^$origin^$wx^$hops^~";}## add one or more users (I am expecting references that have 'call',# 'conf' & 'here' method)## this will create a list of PC16 with up pc16_max_users in each# called $self->pc16(..)#sub pc16{ my $node = shift; my $ncall = $node->call; my @out; my $s = ""; for (@_) { next unless $_; my $ref = $_; my $str = sprintf "^%s %s %d", $ref->call, $ref->conf ? '*' : '-', $ref->here; if (length($s) + length($str) > $sentencelth) { push @out, "PC16^$ncall" . $s . sprintf "^%s^", get_hops(16); $s = ""; } $s .= $str; } push @out, "PC16^$ncall" . $s . sprintf "^%s^", get_hops(16); return @out;}# remove a local usersub pc17{ my @out; while (@_) { my $node = shift; my $ref = shift; my $hops = get_hops(17); my $ncall = $node->call; my $ucall = $ref->call; push @out, "PC17^$ucall^$ncall^$hops^"; } return @out;}# Request init stringsub pc18{ my $flags = " pc9x"; $flags .= " xml" if DXXml::available(); return "PC18^DXSpider Version: $main::version Build: $main::build$flags^$DXProt::myprot_version^";}## add one or more nodes#sub pc19{ my @out; my @in; my $s = ""; for (@_) { next unless $_; my $ref = $_; my $call = $ref->call; my $here = $ref->here; my $conf = $ref->conf; my $version = $ref->version; my $str = "^$here^$call^$conf^$version"; if (length($s) + length($str) > $sentencelth) { push @out, "PC19" . $s . sprintf "^%s^", get_hops(19); $s = ""; } $s .= $str; } push @out, "PC19" . $s . sprintf "^%s^", get_hops(19); return @out;}# end of Rinit phasesub pc20{ return 'PC20^';}# delete a nodesub pc21{ my @out; while (@_) { my $node = shift; my $hops = get_hops(21); my $call = $node->call; push @out, "PC21^$call^Gone^$hops^"; } return @out;}# end of init phasesub pc22{ return 'PC22^';}# here statussub pc24{ my $self = shift; my $call = $self->call; my $flag = $self->here ? '1' : '0'; my $hops = shift || get_hops(24); return "PC24^$call^$flag^$hops^";}# create a merged dx message (freq, dxcall, t, text, spotter, orig-node)sub pc26{ my ($freq, $dxcall, $t, $text, $spotter, $orignode) = @_; $text = ' ' unless $text; $orignode = $main::mycall unless $orignode; return sprintf "PC26^%.1f^$dxcall^%s^%s^$text^$spotter^$orignode^ ^~", $freq, cldate($t), ztime($t);}# create a merged WWV spot (logger, t, sfi, a, k, forecast, orig-node)sub pc27{ my ($logger, $t, $sfi, $a, $k, $forecast, $orignode) = @_; return sprintf "PC27^%s^%-2.2s^$sfi^$a^$k^$forecast^$logger^$orignode^ ^~", cldate($t), ztime($t);}# message start (fromnode, tonode, to, from, t, private, subject, origin)sub pc28{ my ($tonode, $fromnode, $to, $from, $t, $private, $subject, $origin, $rr) = @_; my $date = cldate($t); my $time = ztime($t); $private = $private ? '1' : '0'; $rr = $rr ? '1' : '0'; $subject ||= ' '; return "PC28^$tonode^$fromnode^$to^$from^$date^$time^$private^$subject^ ^5^$rr^ ^$origin^~";}# message text (from and to node same way round as pc29)sub pc29{ my ($fromnode, $tonode, $stream, $text) = @_; $text = ' ' unless defined $text && length $text > 0; $text =~ s/\^/%5E/og; # remove ^ return "PC29^$fromnode^$tonode^$stream^$text^~";}# subject acknowledge (will have to and from node reversed to pc28)sub pc30{ my ($fromnode, $tonode, $stream) = @_; return "PC30^$fromnode^$tonode^$stream^";}# acknowledge this tranche of lines (to and from nodes reversed to pc29 and pc28sub pc31{ my ($fromnode, $tonode, $stream) = @_; return "PC31^$fromnode^$tonode^$stream^";}# end of message from the sending end (pc28 node order)sub pc32{ my ($fromnode, $tonode, $stream) = @_; return "PC32^$fromnode^$tonode^$stream^";}# acknowledge end of message from receiving end (opposite pc28 node order)sub pc33{ my ($fromnode, $tonode, $stream) = @_; return "PC33^$fromnode^$tonode^$stream^";}# remote cmd sendsub pc34{ my($fromnode, $tonode, $msg) = @_; return "PC34^$tonode^$fromnode^$msg^~";}# remote cmd replysub pc35{ my($fromnode, $tonode, $msg) = @_; return "PC35^$tonode^$fromnode^$msg^~";}# send all the DX clusters I reckon are connectedsub pc38{ return join '^', "PC38", map {$_->call} Route::Node::get_all();}# tell the local node to discconnectsub pc39{ my ($call, $reason) = @_; my $hops = get_hops(39); $reason = "Gone." if !$reason; return "PC39^$call^$reason^$hops^";}# cue up bulletin or file for transfersub pc40{ my ($to, $from, $fn, $bull) = @_; $bull = $bull ? '1' : '0'; return "PC40^$to^$from^$fn^$bull^5^";}# user infosub pc41{ my $call = shift; $call = shift if ref $call; my $sort = shift || '0'; my $info = shift || ' '; my $hops = shift || get_hops(41); return "PC41^$call^$sort^$info^$hops^~";}# abort messagesub pc42{ my ($fromnode, $tonode, $stream) = @_; return "PC42^$fromnode^$tonode^$stream^";}# remote db requestsub pc44{ my ($fromnode, $tonode, $stream, $db, $req, $call) = @_; $db = uc $db; return "PC44^$tonode^$fromnode^$stream^$db^$req^$call^";}# remote db datasub pc45{ my ($fromnode, $tonode, $stream, $data) = @_; return "PC45^$tonode^$fromnode^$stream^$data^";}# remote db data completesub pc46{ my ($fromnode, $tonode, $stream) = @_; return "PC46^$tonode^$fromnode^$stream^";}# bull deletesub pc49{ my ($from, $subject) = @_; my $hops = get_hops(49); return "PC49^$from^$subject^$hops^~";}# periodic update of users, plus keep link alive device (always H99)sub pc50{ my $self = shift; my $call = $self->call; my $n = shift || '0'; my $hops = shift || 'H99'; return "PC50^$call^$n^$hops^";}# generate pingssub pc51{ my ($to, $from, $val) = @_; return "PC51^$to^$from^$val^";}# clx remote cmd sendsub pc84{ my($fromnode, $tonode, $call, $msg) = @_; return "PC84^$tonode^$fromnode^$call^$msg^~";}# clx remote cmd replysub pc85{ my($fromnode, $tonode, $call, $msg) = @_; return "PC85^$tonode^$fromnode^$call^$msg^~";}# spider route broadcasts#sub _gen_pc92{ my $sort = shift; my $ext = shift; my $s = "PC92^$main::mycall^" . gen_pc9x_t() . "^$sort"; for (@_) { $s .= "^" . _encode_pc92_call($_, $ext); } return $s . '^H99^';}sub gen_pc92_with_time{ my $call = shift; my $sort = shift; my $t = shift; my $ext = 1; my $s = "PC92^$call^$t^$sort"; for (@_) { $s .= "^" . _encode_pc92_call($_, $ext); } return $s . '^H99^';}# add a local onesub pc92a{ return _gen_pc92('A', 0, @_);}# delete a local onesub pc92d{ return _gen_pc92('D', 0, @_);}# send a configsub pc92c{ return _gen_pc92('C', 1, @_);}# send a 'find' messagesub pc92f{ my $target = shift; my $from = shift; return "PC92^$main::mycall^" . gen_pc9x_t() . "^F^$from^$target^H99^"}# send a 'reply' messagesub pc92r{ my $to = shift; my $target = shift; my $flag = shift; my $ms = shift; return "PC92^$main::mycall^" . gen_pc9x_t() . "^R^$to^$target^$flag^$ms^H99^"}sub pc93{ my $to = shift; # *, callsign, chat group name, sysop my $from = shift; # from user callsign my $via = shift || '*'; # *, node call my $line = shift; # the text my $origin = shift; # this will be present on proxying from PC10 $line = unpad($line); $line =~ s/\^/\\5E/g; # remove any ^ characters my $s = "PC93^$main::mycall^" . gen_pc9x_t() . "^$to^$from^$via^$line"; $s .= "^$origin" if $origin; $s .= "^H99^"; return $s;}1;__END__ diff --cc perl/Route.pm index 8f354524,c2627c9c..2ffd1f2b --- a/perl/Route.pm +++ b/perl/Route.pm @@@ -1,386 -1,391 +1,1 @@@ --#!/usr/bin/perl --# --# This module impliments the abstracted routing for all protocols and --# is probably what I SHOULD have done the first time. --# --# Heyho. --# --# This is just a container class which I expect to subclass --# --# Copyright (c) 2001 Dirk Koopman G1TLH --# --# $Id$ --# -- --package Route; -- --use DXDebug; --use DXChannel; --use Prefix; -use DXUtil; -- --use strict; -- -- --use vars qw(%list %valid $filterdef); -- --%valid = ( -- call => "0,Callsign", -- flags => "0,Flags,phex", -- dxcc => '0,Country Code', -- itu => '0,ITU Zone', -- cq => '0,CQ Zone', -- state => '0,State', -- city => '0,City', -- ); -- --$filterdef = bless ([ -- # tag, sort, field, priv, special parser -- ['channel', 'c', 0], -- ['channel_dxcc', 'nc', 1], -- ['channel_itu', 'ni', 2], -- ['channel_zone', 'nz', 3], -- ['call', 'c', 4], -- ['by', 'c', 4], -- ['call_dxcc', 'nc', 5], -- ['by_dxcc', 'nc', 5], -- ['call_itu', 'ni', 6], -- ['by_itu', 'ni', 6], -- ['call_zone', 'nz', 7], -- ['by_zone', 'nz', 7], -- ['channel_state', 'ns', 8], -- ['call_state', 'ns', 9], -- ['by_state', 'ns', 9], -- ], 'Filter::Cmd'); -- -- --sub new --{ -- my ($pkg, $call) = @_; -- $pkg = ref $pkg if ref $pkg; -- -- my $self = bless {call => $call}, $pkg; -- dbg("create $pkg with $call") if isdbg('routelow'); -- -- # add in all the dxcc, itu, zone info -- ($self->{dxcc}, $self->{itu}, $self->{cq}, $self->{state}, $self->{city}) = -- Prefix::cty_data($call); -- -- $self->{flags} = here(1); -- -- return $self; --} -- --# --# get a callsign from a passed reference or a string --# -- --sub _getcall --{ -- my $self = shift; -- my $thingy = shift; -- $thingy = $self unless $thingy; -- $thingy = $thingy->call if ref $thingy; -- $thingy = uc $thingy if $thingy; -- return $thingy; --} -- --# --# add and delete a callsign to/from a list --# -- --sub _addlist --{ -- my $self = shift; -- my $field = shift; -- my @out; -- foreach my $c (@_) { -- confess "Need a ref here" unless ref($c); -- -- my $call = $c->{call}; -- unless (grep $_ eq $call, @{$self->{$field}}) { -- push @{$self->{$field}}, $call; -- dbg(ref($self) . " adding $call to " . $self->{call} . "->\{$field\}") if isdbg('routelow'); -- push @out, $c; -- } -- } -- return @out; --} -- --sub _dellist --{ -- my $self = shift; -- my $field = shift; -- my @out; -- foreach my $c (@_) { -- confess "Need a ref here" unless ref($c); -- my $call = $c->{call}; -- if (grep $_ eq $call, @{$self->{$field}}) { -- $self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ]; -- dbg(ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}") if isdbg('routelow'); -- push @out, $c; -- } -- } -- return @out; --} -- --sub is_empty --{ -- my $self = shift; -- return @{$self->{$_[0]}} == 0; --} -- --# --# flag field constructors/enquirers --# --# These can be called in various ways:- --# --# Route::here or $ref->here returns 1 or 0 depending on value of the here flag --# Route::here(1) returns 2 (the bit value of the here flag) --# $ref->here(1) or $ref->here(0) sets the here flag --# -- --sub here --{ -- my $self = shift; -- my $r = shift; -- return $self ? 2 : 0 unless ref $self; -- return ($self->{flags} & 2) ? 1 : 0 unless defined $r; -- $self->{flags} = (($self->{flags} & ~2) | ($r ? 2 : 0)); -- return $r ? 1 : 0; --} -- --sub conf --{ -- my $self = shift; -- my $r = shift; -- return $self ? 1 : 0 unless ref $self; -- return ($self->{flags} & 1) ? 1 : 0 unless defined $r; -- $self->{flags} = (($self->{flags} & ~1) | ($r ? 1 : 0)); -- return $r ? 1 : 0; --} -- --sub parents --{ -- my $self = shift; -- return @{$self->{parent}}; --} -- --# --# display routines --# -- --sub user_call --{ -- my $self = shift; -- my $call = sprintf "%s", $self->{call}; -- return $self->here ? "$call" : "($call)"; --} -- --sub config --{ -- my $self = shift; -- my $nodes_only = shift; -- my $level = shift; -- my $seen = shift; -- my @out; -- my $line; -- my $call = $self->user_call; -- my $printit = 1; -- -- # allow ranges -- if (@_) { -- $printit = grep $call =~ m|$_|, @_; -- } -- -- if ($printit) { - $line = ' ' x ($level*2) . "$call"; - $call = ' ' x length $call; - my $pcall = $call; - $pcall .= ":" . $self->obscount if $self->via_pc92; - - - $line = ' ' x ($level*2) . "$pcall"; - $call = ' ' x length $pcall; -- -- # recursion detector -- if ((DXChannel::get($self->{call}) && $level > 1) || grep $self->{call} eq $_, @$seen) { -- $line .= ' ...'; -- push @out, $line; -- return @out; -- } -- push @$seen, $self->{call}; -- -- # print users -- unless ($nodes_only) { -- if (@{$self->{users}}) { -- $line .= '->'; -- foreach my $ucall (sort @{$self->{users}}) { -- my $uref = Route::User::get($ucall); -- my $c; -- if ($uref) { -- $c = $uref->user_call; -- } else { -- $c = "$ucall?"; -- } -- if ((length $line) + (length $c) + 1 < 79) { -- $line .= $c . ' '; -- } else { -- $line =~ s/\s+$//; -- push @out, $line; -- $line = ' ' x ($level*2) . "$call->$c "; -- } -- } -- } -- } -- $line =~ s/->$//g; -- $line =~ s/\s+$//; -- push @out, $line if length $line; -- } -- -- # deal with more nodes -- foreach my $ncall (sort @{$self->{nodes}}) { -- my $nref = Route::Node::get($ncall); -- -- if ($nref) { -- my $c = $nref->user_call; --# dbg("recursing from $call -> $c") if isdbg('routec'); -- push @out, $nref->config($nodes_only, $level+1, $seen, @_); -- } else { -- push @out, ' ' x (($level+1)*2) . "$ncall?" if @_ == 0 || (@_ && grep $ncall =~ m|$_|, @_); -- } -- } -- -- return @out; --} -- --sub cluster --{ -- my $nodes = Route::Node::count(); -- my $tot = Route::User::count(); -- my $users = scalar DXCommandmode::get_all(); -- my $maxusers = Route::User::max(); -- my $uptime = main::uptime(); -- -- return " $nodes nodes, $users local / $tot total users Max users $maxusers Uptime $uptime"; --} -- --# --# routing things --# -- --sub get --{ -- my $call = shift; -- return Route::Node::get($call) || Route::User::get($call); --} -- --# find all the possible dxchannels which this object might be on --sub alldxchan --{ -- my $self = shift; -- my @dxchan; --# dbg("Trying node $self->{call}") if isdbg('routech'); -- -- my $dxchan = DXChannel::get($self->{call}); -- push @dxchan, $dxchan if $dxchan; -- -- # it isn't, build up a list of dxchannels and possible ping times -- # for all the candidates. -- unless (@dxchan) { -- foreach my $p (@{$self->{parent}}) { --# dbg("Trying parent $p") if isdbg('routech'); -- next if $p eq $main::mycall; # the root -- my $dxchan = DXChannel::get($p); -- if ($dxchan) { -- push @dxchan, $dxchan unless grep $dxchan == $_, @dxchan; -- } else { -- next if grep $p eq $_, @_; -- my $ref = Route::Node::get($p); --# dbg("Next node $p " . ($ref ? 'Found' : 'NOT Found') if isdbg('routech') ); -- push @dxchan, $ref->alldxchan($self->{call}, @_) if $ref; -- } -- } -- } --# dbg('routech', "Got dxchan: " . join(',', (map{ $_->call } @dxchan)) ); -- return @dxchan; --} -- --sub dxchan --{ -- my $self = shift; -- -- # ALWAYS return the locally connected channel if present; -- my $dxchan = DXChannel::get($self->call); -- return $dxchan if $dxchan; -- -- my @dxchan = $self->alldxchan; -- return undef unless @dxchan; -- -- # determine the minimum ping channel -- my $minping = 99999999; -- foreach my $dxc (@dxchan) { -- my $p = $dxc->pingave; -- if (defined $p && $p < $minping) { -- $minping = $p; -- $dxchan = $dxc; -- } -- } -- $dxchan = shift @dxchan unless $dxchan; -- return $dxchan; --} -- -- -- --# --# track destruction --# -- --sub DESTROY --{ -- my $self = shift; -- my $pkg = ref $self; -- -- dbg("$pkg $self->{call} destroyed") if isdbg('routelow'); --} -- --no strict; --# --# return a list of valid elements --# -- --sub fields --{ -- my $pkg = shift; -- $pkg = ref $pkg if ref $pkg; -- my $val = "${pkg}::valid"; -- my @out = keys %$val; -- push @out, keys %valid; -- return @out; --} -- --# --# return a prompt for a field --# -- --sub field_prompt --{ -- my ($self, $ele) = @_; -- my $pkg = ref $self; -- my $val = "${pkg}::valid"; -- return $val->{$ele} || $valid{$ele}; --} -- --# --# generic AUTOLOAD for accessors --# --sub AUTOLOAD --{ -- no strict; -- my $name = $AUTOLOAD; -- return if $name =~ /::DESTROY$/; -- $name =~ s/^.*:://o; -- -- confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; -- -- # this clever line of code creates a subroutine which takes over from autoload -- # from OO Perl - Conway -- *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; -- goto &$AUTOLOAD; -- --} -- --1; ++#!/usr/bin/perl## This module impliments the abstracted routing for all protocols and# is probably what I SHOULD have done the first time.## Heyho.## This is just a container class which I expect to subclass## Copyright (c) 2001 Dirk Koopman G1TLH## $Id$#package Route;use DXDebug;use DXChannel;use Prefix;use DXUtil;use strict;use vars qw(%list %valid $filterdef);%valid = ( call => "0,Callsign", flags => "0,Flags,phex", dxcc => '0,Country Code', itu => '0,ITU Zone', cq => '0,CQ Zone', state => '0,State', city => '0,City', );$filterdef = bless ([ # tag, sort, field, priv, special parser ['channel', 'c', 0], ['channel_dxcc', 'nc', 1], ['channel_itu', 'ni', 2], ['channel_zone', 'nz', 3], ['call', 'c', 4], ['by', 'c', 4], ['call_dxcc', 'nc', 5], ['by_dxcc', 'nc', 5], ['call_itu', 'ni', 6], ['by_itu', 'ni', 6], ['call_zone', 'nz', 7], ['by_zone', 'nz', 7], ['channel_state', 'ns', 8], ['call_state', 'ns', 9], ['by_state', 'ns', 9], ], 'Filter::Cmd');sub new{ my ($pkg, $call) = @_; $pkg = ref $pkg if ref $pkg; my $self = bless {call => $call}, $pkg; dbg("create $pkg with $call") if isdbg('routelow'); # add in all the dxcc, itu, zone info ($self->{dxcc}, $self->{itu}, $self->{cq}, $self->{state}, $self->{city}) = Prefix::cty_data($call); $self->{flags} = here(1); return $self;}## get a callsign from a passed reference or a string#sub _getcall{ my $self = shift; my $thingy = shift; $thingy = $self unless $thingy; $thingy = $thingy->call if ref $thingy; $thingy = uc $thingy if $thingy; return $thingy;}## add and delete a callsign to/from a list#sub _addlist{ my $self = shift; my $field = shift; my @out; foreach my $c (@_) { confess "Need a ref here" unless ref($c); my $call = $c->{call}; unless (grep $_ eq $call, @{$self->{$field}}) { push @{$self->{$field}}, $call; dbg(ref($self) . " adding $call to " . $self->{call} . "->\{$field\}") if isdbg('routelow'); push @out, $c; } } return @out;}sub _dellist{ my $self = shift; my $field = shift; my @out; foreach my $c (@_) { confess "Need a ref here" unless ref($c); my $call = $c->{call}; if (grep $_ eq $call, @{$self->{$field}}) { $self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ]; dbg(ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}") if isdbg('routelow'); push @out, $c; } } return @out;}sub is_empty{ my $self = shift; return @{$self->{$_[0]}} == 0;}## flag field constructors/enquirers## These can be called in various ways:-## Route::here or $ref->here returns 1 or 0 depending on value of the here flag# Route::here(1) returns 2 (the bit value of the here flag)# $ref->here(1) or $ref->here(0) sets the here flag#sub here{ my $self = shift; my $r = shift; return $self ? 2 : 0 unless ref $self; return ($self->{flags} & 2) ? 1 : 0 unless defined $r; $self->{flags} = (($self->{flags} & ~2) | ($r ? 2 : 0)); return $r ? 1 : 0;}sub conf{ my $self = shift; my $r = shift; return $self ? 1 : 0 unless ref $self; return ($self->{flags} & 1) ? 1 : 0 unless defined $r; $self->{flags} = (($self->{flags} & ~1) | ($r ? 1 : 0)); return $r ? 1 : 0;}sub parents{ my $self = shift; return @{$self->{parent}};}## display routines#sub user_call{ my $self = shift; my $call = sprintf "%s", $self->{call}; return $self->here ? "$call" : "($call)";}sub config{ my $self = shift; my $nodes_only = shift; my $level = shift; my $seen = shift; my @out; my $line; my $call = $self->user_call; my $printit = 1; # allow ranges if (@_) { $printit = grep $call =~ m|$_|, @_; } if ($printit) { my $pcall = $call; $pcall .= ":" . $self->obscount if $self->via_pc92; $line = ' ' x ($level*2) . "$pcall"; $call = ' ' x length $pcall; # recursion detector if ((DXChannel::get($self->{call}) && $level > 1) || grep $self->{call} eq $_, @$seen) { $line .= ' ...'; push @out, $line; return @out; } push @$seen, $self->{call}; # print users unless ($nodes_only) { if (@{$self->{users}}) { $line .= '->'; foreach my $ucall (sort @{$self->{users}}) { my $uref = Route::User::get($ucall); my $c; if ($uref) { $c = $uref->user_call; } else { $c = "$ucall?"; } if ((length $line) + (length $c) + 1 < 79) { $line .= $c . ' '; } else { $line =~ s/\s+$//; push @out, $line; $line = ' ' x ($level*2) . "$call->$c "; } } } } $line =~ s/->$//g; $line =~ s/\s+$//; push @out, $line if length $line; } # deal with more nodes foreach my $ncall (sort @{$self->{nodes}}) { my $nref = Route::Node::get($ncall); if ($nref) { my $c = $nref->user_call;# dbg("recursing from $call -> $c") if isdbg('routec'); push @out, $nref->config($nodes_only, $level+1, $seen, @_); } else { push @out, ' ' x (($level+1)*2) . "$ncall?" if @_ == 0 || (@_ && grep $ncall =~ m|$_|, @_); } } return @out;}sub cluster{ my $nodes = Route::Node::count(); my $tot = Route::User::count(); my $users = scalar DXCommandmode::get_all(); my $maxusers = Route::User::max(); my $uptime = main::uptime(); return " $nodes nodes, $users local / $tot total users Max users $maxusers Uptime $uptime";}## routing things#sub get{ my $call = shift; return Route::Node::get($call) || Route::User::get($call);}# find all the possible dxchannels which this object might be onsub alldxchan{ my $self = shift; my @dxchan;# dbg("Trying node $self->{call}") if isdbg('routech'); my $dxchan = DXChannel::get($self->{call}); push @dxchan, $dxchan if $dxchan; # it isn't, build up a list of dxchannels and possible ping times # for all the candidates. unless (@dxchan) { foreach my $p (@{$self->{parent}}) {# dbg("Trying parent $p") if isdbg('routech'); next if $p eq $main::mycall; # the root my $dxchan = DXChannel::get($p); if ($dxchan) { push @dxchan, $dxchan unless grep $dxchan == $_, @dxchan; } else { next if grep $p eq $_, @_; my $ref = Route::Node::get($p);# dbg("Next node $p " . ($ref ? 'Found' : 'NOT Found') if isdbg('routech') ); push @dxchan, $ref->alldxchan($self->{call}, @_) if $ref; } } }# dbg('routech', "Got dxchan: " . join(',', (map{ $_->call } @dxchan)) ); return @dxchan;}sub dxchan{ my $self = shift; # ALWAYS return the locally connected channel if present; my $dxchan = DXChannel::get($self->call); return $dxchan if $dxchan; my @dxchan = $self->alldxchan; return undef unless @dxchan; # determine the minimum ping channel my $minping = 99999999; foreach my $dxc (@dxchan) { my $p = $dxc->pingave; if (defined $p && $p < $minping) { $minping = $p; $dxchan = $dxc; } } $dxchan = shift @dxchan unless $dxchan; return $dxchan;}## track destruction#sub DESTROY{ my $self = shift; my $pkg = ref $self; dbg("$pkg $self->{call} destroyed") if isdbg('routelow');}no strict;## return a list of valid elements#sub fields{ my $pkg = shift; $pkg = ref $pkg if ref $pkg; my $val = "${pkg}::valid"; my @out = keys %$val; push @out, keys %valid; return @out;}## return a prompt for a field#sub field_prompt{ my ($self, $ele) = @_; my $pkg = ref $self; my $val = "${pkg}::valid"; return $val->{$ele} || $valid{$ele};}## generic AUTOLOAD for accessors#sub AUTOLOAD{ no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; goto &$AUTOLOAD;}1; diff --cc perl/Route/Node.pm index f80e58e3,4b08de3b..6181e2d8 --- a/perl/Route/Node.pm +++ b/perl/Route/Node.pm @@@ -1,324 -1,376 +1,1 @@@ --# --# Node routing routines --# --# Copyright (c) 2001 Dirk Koopman G1TLH --# --# $Id$ --# -- --package Route::Node; -- --use DXDebug; --use Route; --use Route::User; -use DXUtil; -- --use strict; -- - use vars qw(%list %valid @ISA $max $filterdef); -use vars qw(%list %valid @ISA $max $filterdef $obscount); --@ISA = qw(Route); -- --%valid = ( -- parent => '0,Parent Calls,parray', -- nodes => '0,Nodes,parray', -- users => '0,Users,parray', -- usercount => '0,User Count', -- version => '0,Version', -- handle_xml => '0,Using XML,yesno', -- lastmsg => '0,Last Route Msg,atime', -- lastid => '0,Last Route MsgID', - do_pc9x => '0,Uses pc9x,yesno', - via_pc92 => '0,Came in via pc92,yesno', - obscount => '0,Obscount', --); -- --$filterdef = $Route::filterdef; --%list = (); --$max = 0; -$obscount = 3; -- --sub count --{ -- my $n = scalar (keys %list); -- $max = $n if $n > $max; -- return $n; --} -- --sub max --{ -- count(); -- return $max; --} -- --# --# this routine handles the possible adding of an entry in the routing --# table. It will only add an entry if it is new. It may have all sorts of --# other side effects which may include fixing up other links. --# --# It will return a node object if (and only if) it is a completely new --# object with that callsign. The upper layers are expected to do something --# sensible with this! --# --# called as $parent->add(call, dxchan, version, flags) --# -- --sub add --{ -- my $parent = shift; -- my $call = uc shift; -- confess "Route::add trying to add $call to myself" if $call eq $parent->{call}; -- my $self = get($call); -- if ($self) { -- $self->_addparent($parent); -- $parent->_addnode($self); -- return undef; -- } -- $self = $parent->new($call, @_); -- $parent->_addnode($self); -- return $self; --} -- --# --# this routine is the opposite of 'add' above. --# --# It will return an object if (and only if) this 'del' will remove --# this object completely --# -- --sub del --{ -- my $self = shift; -- my $pref = shift; -- -- # delete parent from this call's parent list -- $pref->_delnode($self); -- $self->_delparent($pref); -- my @nodes; -- my $ncall = $self->{call}; -- -- # is this the last connection, I have no parents anymore? -- unless (@{$self->{parent}}) { -- foreach my $rcall (@{$self->{nodes}}) { -- next if grep $rcall eq $_, @_; -- my $r = Route::Node::get($rcall); -- push @nodes, $r->del($self, $ncall, @_) if $r; -- } -- $self->_del_users; -- delete $list{$self->{call}}; -- push @nodes, $self; -- } -- return @nodes; --} -- --# this deletes this node completely by grabbing the parents --# and deleting me from them --sub delete --{ -- my $self = shift; -- my @out; -- -- $self->_del_users; -- foreach my $call (@{$self->{parent}}) { -- my $parent = Route::Node::get($call); -- push @out, $parent->del($self) if $parent; -- } -- return @out; --} -- --sub del_nodes --{ -- my $parent = shift; -- my @out; -- foreach my $rcall (@{$parent->{nodes}}) { -- my $r = get($rcall); -- push @out, $r->del($parent, $parent->{call}, @_) if $r; -- } -- return @out; --} -- --sub _del_users --{ -- my $self = shift; -- for (@{$self->{users}}) { -- my $ref = Route::User::get($_); -- $ref->del($self) if $ref; -- } -- $self->{users} = []; --} -- --# add a user to this node --sub add_user --{ -- my $self = shift; -- my $ucall = shift; -- -- confess "Trying to add NULL User call to routing tables" unless $ucall; -- -- my $uref = Route::User::get($ucall); -- my @out; -- if ($uref) { -- @out = $uref->addparent($self); -- } else { -- $uref = Route::User->new($ucall, $self->{call}, @_); -- @out = $uref; -- } -- $self->_adduser($uref); -- $self->{usercount} = scalar @{$self->{users}}; -- -- return @out; --} -- --# delete a user from this node --sub del_user --{ -- my $self = shift; -- my $ref = shift; -- my @out; -- -- if ($ref) { -- @out = $self->_deluser($ref); -- $ref->del($self); -- } else { -- confess "tried to delete non-existant $ref->{call} from $self->{call}"; -- } -- $self->{usercount} = scalar @{$self->{users}}; -- return @out; --} -- --sub usercount --{ -- my $self = shift; -- if (@_ && @{$self->{users}} == 0) { -- $self->{usercount} = shift; -- } -- return $self->{usercount}; --} -- --sub users --{ -- my $self = shift; -- return @{$self->{users}}; --} -- --sub nodes --{ -- my $self = shift; -- return @{$self->{nodes}}; --} -- --sub parents --{ -- my $self = shift; -- return @{$self->{parent}}; --} -- --sub rnodes --{ -- my $self = shift; -- my @out; -- foreach my $call (@{$self->{nodes}}) { -- next if grep $call eq $_, @_; -- push @out, $call; -- my $r = get($call); -- push @out, $r->rnodes($call, @_) if $r; -- } -- return @out; --} -- -# this takes in a list of node and user calls (not references) from -# a config type update for a node and returns -# the differences as lists of things that have gone away -# and things that have been added. -sub calc_config_changes -{ - my $self = shift; - my %nodes = map {$_ => 1} @{$self->{nodes}}; - my %users = map {$_ => 1} @{$self->{users}}; - my $cnodes = shift; - my $cusers = shift; - if (isdbg('route')) { - dbg("ROUTE: start calc_config_changes"); - dbg("ROUTE: incoming nodes on $self->{call}: " . join(',', sort @$cnodes)); - dbg("ROUTE: incoming users on $self->{call}: " . join(',', sort @$cusers)); - dbg("ROUTE: existing nodes on $self->{call}: " . join(',', sort keys %nodes)); - dbg("ROUTE: existing users on $self->{call}: " . join(',', sort keys %users)); - } - my (@dnodes, @dusers, @nnodes, @nusers); - push @nnodes, map {my @r = $nodes{$_} ? () : $_; delete $nodes{$_}; @r} @$cnodes; - push @dnodes, keys %nodes; - push @nusers, map {my @r = $users{$_} ? () : $_; delete $users{$_}; @r} @$cusers; - push @dusers, keys %users; - if (isdbg('route')) { - dbg("ROUTE: deleted nodes on $self->{call}: " . join(',', sort @dnodes)); - dbg("ROUTE: deleted users on $self->{call}: " . join(',', sort @dusers)); - dbg("ROUTE: added nodes on $self->{call}: " . join(',', sort @nnodes)); - dbg("ROUTE: added users on $self->{call}: " . join(',', sort @nusers)); - dbg("ROUTE: end calc_config_changes"); - } - return (\@dnodes, \@dusers, \@nnodes, \@nusers); -} -- --sub new --{ -- my $pkg = shift; -- my $call = uc shift; -- -- confess "already have $call in $pkg" if $list{$call}; -- -- my $self = $pkg->SUPER::new($call); -- $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ]; - $self->{version} = shift; - $self->{flags} = shift; - $self->{version} = shift || 5401; - $self->{flags} = shift || Route::here(1); -- $self->{users} = []; -- $self->{nodes} = []; - $self->{lastid} = {}; - $self->reset_obs; # by definition -- -- $list{$call} = $self; -- -- return $self; --} -- --sub get --{ -- my $call = shift; -- $call = shift if ref $call; -- my $ref = $list{uc $call}; -- dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr'); -- return $ref; --} -- --sub get_all --{ -- return values %list; --} -- --sub _addparent --{ -- my $self = shift; -- return $self->_addlist('parent', @_); --} -- --sub _delparent --{ -- my $self = shift; -- return $self->_dellist('parent', @_); --} -- -- --sub _addnode --{ -- my $self = shift; -- return $self->_addlist('nodes', @_); --} -- --sub _delnode --{ -- my $self = shift; -- return $self->_dellist('nodes', @_); --} -- -- --sub _adduser --{ -- my $self = shift; -- return $self->_addlist('users', @_); --} -- --sub _deluser --{ -- my $self = shift; -- return $self->_dellist('users', @_); -} - -sub dec_obs -{ - my $self = shift; - $self->{obscount}--; - return $self->{obscount}; -} - -sub reset_obs -{ - my $self = shift; - $self->{obscount} = $obscount; --} -- --sub DESTROY --{ -- my $self = shift; -- my $pkg = ref $self; -- my $call = $self->{call} || "Unknown"; -- -- dbg("destroying $pkg with $call") if isdbg('routelow'); --} -- --# --# generic AUTOLOAD for accessors --# -- --sub AUTOLOAD --{ -- no strict; -- my $name = $AUTOLOAD; -- return if $name =~ /::DESTROY$/; -- $name =~ s/^.*:://o; -- -- confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name}; -- -- # this clever line of code creates a subroutine which takes over from autoload -- # from OO Perl - Conway -- *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}}; -- goto &$AUTOLOAD; --} -- --1; -- ++## Node routing routines## Copyright (c) 2001 Dirk Koopman G1TLH## $Id$#package Route::Node;use DXDebug;use Route;use Route::User;use DXUtil;use strict;use vars qw(%list %valid @ISA $max $filterdef $obscount);@ISA = qw(Route);%valid = ( parent => '0,Parent Calls,parray', nodes => '0,Nodes,parray', users => '0,Users,parray', usercount => '0,User Count', version => '0,Version', handle_xml => '0,Using XML,yesno', lastmsg => '0,Last Route Msg,atime', lastid => '0,Last Route MsgID', do_pc9x => '0,Uses pc9x,yesno', via_pc92 => '0,Came in via pc92,yesno', obscount => '0,Obscount',);$filterdef = $Route::filterdef;%list = ();$max = 0;$obscount = 3;sub count{ my $n = scalar (keys %list); $max = $n if $n > $max; return $n;}sub max{ count(); return $max;}## this routine handles the possible adding of an entry in the routing# table. It will only add an entry if it is new. It may have all sorts of# other side effects which may include fixing up other links.## It will return a node object if (and only if) it is a completely new# object with that callsign. The upper layers are expected to do something# sensible with this!## called as $parent->add(call, dxchan, version, flags)#sub add{ my $parent = shift; my $call = uc shift; confess "Route::add trying to add $call to myself" if $call eq $parent->{call}; my $self = get($call); if ($self) { $self->_addparent($parent); $parent->_addnode($self); return undef; } $self = $parent->new($call, @_); $parent->_addnode($self); return $self;}## this routine is the opposite of 'add' above.## It will return an object if (and only if) this 'del' will remove# this object completely#sub del{ my $self = shift; my $pref = shift; # delete parent from this call's parent list $pref->_delnode($self); $self->_delparent($pref); my @nodes; my $ncall = $self->{call}; # is this the last connection, I have no parents anymore? unless (@{$self->{parent}}) { foreach my $rcall (@{$self->{nodes}}) { next if grep $rcall eq $_, @_; my $r = Route::Node::get($rcall); push @nodes, $r->del($self, $ncall, @_) if $r; } $self->_del_users; delete $list{$self->{call}}; push @nodes, $self; } return @nodes;}# this deletes this node completely by grabbing the parents# and deleting me from themsub delete{ my $self = shift; my @out; $self->_del_users; foreach my $call (@{$self->{parent}}) { my $parent = Route::Node::get($call); push @out, $parent->del($self) if $parent; } return @out;}sub del_nodes{ my $parent = shift; my @out; foreach my $rcall (@{$parent->{nodes}}) { my $r = get($rcall); push @out, $r->del($parent, $parent->{call}, @_) if $r; } return @out;}sub _del_users{ my $self = shift; for (@{$self->{users}}) { my $ref = Route::User::get($_); $ref->del($self) if $ref; } $self->{users} = [];}# add a user to this nodesub add_user{ my $self = shift; my $ucall = shift; confess "Trying to add NULL User call to routing tables" unless $ucall; my $uref = Route::User::get($ucall); my @out; if ($uref) { @out = $uref->addparent($self); } else { $uref = Route::User->new($ucall, $self->{call}, @_); @out = $uref; } $self->_adduser($uref); $self->{usercount} = scalar @{$self->{users}}; return @out;}# delete a user from this nodesub del_user{ my $self = shift; my $ref = shift; my @out; if ($ref) { @out = $self->_deluser($ref); $ref->del($self); } else { confess "tried to delete non-existant $ref->{call} from $self->{call}"; } $self->{usercount} = scalar @{$self->{users}}; return @out;}sub usercount{ my $self = shift; if (@_ && @{$self->{users}} == 0) { $self->{usercount} = shift; } return $self->{usercount};}sub users{ my $self = shift; return @{$self->{users}};}sub nodes{ my $self = shift; return @{$self->{nodes}};}sub parents{ my $self = shift; return @{$self->{parent}};}sub rnodes{ my $self = shift; my @out; foreach my $call (@{$self->{nodes}}) { next if grep $call eq $_, @_; push @out, $call; my $r = get($call); push @out, $r->rnodes($call, @_) if $r; } return @out;}# this takes in a list of node and user calls (not references) from# a config type update for a node and returns# the differences as lists of things that have gone away# and things that have been added.sub calc_config_changes{ my $self = shift; my %nodes = map {$_ => 1} @{$self->{nodes}}; my %users = map {$_ => 1} @{$self->{users}}; my $cnodes = shift; my $cusers = shift; if (isdbg('route')) { dbg("ROUTE: start calc_config_changes"); dbg("ROUTE: incoming nodes on $self->{call}: " . join(',', sort @$cnodes)); dbg("ROUTE: incoming users on $self->{call}: " . join(',', sort @$cusers)); dbg("ROUTE: existing nodes on $self->{call}: " . join(',', sort keys %nodes)); dbg("ROUTE: existing users on $self->{call}: " . join(',', sort keys %users)); } my (@dnodes, @dusers, @nnodes, @nusers); push @nnodes, map {my @r = $nodes{$_} ? () : $_; delete $nodes{$_}; @r} @$cnodes; push @dnodes, keys %nodes; push @nusers, map {my @r = $users{$_} ? () : $_; delete $users{$_}; @r} @$cusers; push @dusers, keys %users; if (isdbg('route')) { dbg("ROUTE: deleted nodes on $self->{call}: " . join(',', sort @dnodes)); dbg("ROUTE: deleted users on $self->{call}: " . join(',', sort @dusers)); dbg("ROUTE: added nodes on $self->{call}: " . join(',', sort @nnodes)); dbg("ROUTE: added users on $self->{call}: " . join(',', sort @nusers)); dbg("ROUTE: end calc_config_changes"); } return (\@dnodes, \@dusers, \@nnodes, \@nusers);}sub new{ my $pkg = shift; my $call = uc shift; confess "already have $call in $pkg" if $list{$call}; my $self = $pkg->SUPER::new($call); $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ]; $self->{version} = shift || 5401; $self->{flags} = shift || Route::here(1); $self->{users} = []; $self->{nodes} = []; $self->{lastid} = {}; $self->reset_obs; # by definition $list{$call} = $self; return $self;}sub get{ my $call = shift; $call = shift if ref $call; my $ref = $list{uc $call}; dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr'); return $ref;}sub get_all{ return values %list;}sub _addparent{ my $self = shift; return $self->_addlist('parent', @_);}sub _delparent{ my $self = shift; return $self->_dellist('parent', @_);}sub _addnode{ my $self = shift; return $self->_addlist('nodes', @_);}sub _delnode{ my $self = shift; return $self->_dellist('nodes', @_);}sub _adduser{ my $self = shift; return $self->_addlist('users', @_);}sub _deluser{ my $self = shift; return $self->_dellist('users', @_);}sub dec_obs{ my $self = shift; $self->{obscount}--; return $self->{obscount};}sub reset_obs{ my $self = shift; $self->{obscount} = $obscount;}sub DESTROY{ my $self = shift; my $pkg = ref $self; my $call = $self->{call} || "Unknown"; dbg("destroying $pkg with $call") if isdbg('routelow');}## generic AUTOLOAD for accessors#sub AUTOLOAD{ no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}}; goto &$AUTOLOAD;}1; diff --cc perl/Version.pm index dac731e1,c77cd83e..e0809051 --- a/perl/Version.pm +++ b/perl/Version.pm @@@ -9,7 -9,7 +9,7 @@@ package main use vars qw($version $build); -$version = '1.54'; -$build = '48'; +$version = '1.53'; - $build = '16'; ++$build = '17'; 1; diff --cc perl/cluster.pl index 37ace021,deb17c75..9534adad --- a/perl/cluster.pl +++ b/perl/cluster.pl @@@ -1,525 -1,549 +1,1 @@@ --#!/usr/bin/perl -w --# --# This is the DX cluster 'daemon'. It sits in the middle of its little --# web of client routines sucking and blowing data where it may. --# --# Hence the name of 'spider' (although it may become 'dxspider') --# --# Copyright (c) 1998 Dirk Koopman G1TLH --# --# $Id$ --# -- --require 5.004; -- --# make sure that modules are searched in the order local then perl --BEGIN { -- umask 002; -- -- # root of directory tree for this system -- $root = "/spider"; -- $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; -- -- unshift @INC, "$root/perl"; # this IS the right way round! -- unshift @INC, "$root/local"; -- -- # do some validation of the input -- die "The directory $root doesn't exist, please RTFM" unless -d $root; -- die "$root/local doesn't exist, please RTFM" unless -d "$root/local"; -- die "$root/local/DXVars.pm doesn't exist, please RTFM" unless -e "$root/local/DXVars.pm"; -- -- mkdir "$root/local_cmd", 0777 unless -d "$root/local_cmd"; -- -- -- # try to create and lock a lockfile (this isn't atomic but -- # should do for now -- $lockfn = "$root/local/cluster.lck"; # lock file name -- if (-e $lockfn) { -- open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!"; -- my $pid = ; -- chomp $pid; -- die "Lockfile ($lockfn) and process $pid exist, another cluster running?" if kill 0, $pid; -- close CLLOCK; -- } -- open(CLLOCK, ">$lockfn") or die "Can't open Lockfile ($lockfn) $!"; -- print CLLOCK "$$\n"; -- close CLLOCK; -- -- $is_win = ($^O =~ /^MS/ || $^O =~ /^OS-2/) ? 1 : 0; # is it Windows? -- $systime = time; --} -- --use DXVars; --use Msg; --use IntMsg; --use Internet; --use Listeners; --use ExtMsg; --use AGWConnect; --use AGWMsg; --use DXDebug; --use DXLog; --use DXLogPrint; --use DXUtil; --use DXChannel; --use DXUser; --use DXM; --use DXCommandmode; --use DXProtVars; --use DXProtout; --use DXProt; --use DXMsg; --use DXCron; --use DXConnect; --use DXBearing; --use DXDb; --use DXHash; --use DXDupe; --use Script; --use Prefix; --use Spot; --use Bands; --use Keps; --use Minimuf; --use Sun; --use Geomag; --use CmdAlias; --use Filter; --use AnnTalk; --use BBS; --use WCY; --use BadWords; --use Timer; --use Route; --use Route::Node; --use Route::User; --use Editable; --use Mrtg; --use USDB; --use UDPMsg; --use QSL; --use RouteDB; --use DXXml; --use DXSql; --use IsoTime; -- --use Data::Dumper; --use IO::File; --use Fcntl ':flock'; --use POSIX ":sys_wait_h"; --use Version; -- --use Local; -- --package main; -- --use strict; - use vars qw(@inqueue $systime $version $starttime $lockfn @outstanding_connects -use vars qw(@inqueue $systime $starttime $lockfn @outstanding_connects -- $zombies $root @listeners $lang $myalias @debug $userfn $clusteraddr -- $clusterport $mycall $decease $is_win $routeroot $me $reqreg $bumpexisting - $allowdxby $dbh $dsn $dbuser $dbpass $do_xml - $allowdxby $dbh $dsn $dbuser $dbpass $do_xml $systime_days $systime_daystart - $can_encode -- ); -- --@inqueue = (); # the main input queue, an array of hashes --$systime = 0; # the time now (in seconds) --$starttime = 0; # the starting time of the cluster --@outstanding_connects = (); # list of outstanding connects --@listeners = (); # list of listeners --$reqreg = 0; # 1 = registration required, 2 = deregister people --$bumpexisting = 1; # 1 = allow new connection to disconnect old, 0 - don't allow it --$allowdxby = 0; # 1 = allow "dx by ", 0 - don't allow it -- -- --# send a message to call on conn and disconnect --sub already_conn --{ -- my ($conn, $call, $mess) = @_; -- -- $conn->disable_read(1); -- dbg("-> D $call $mess\n") if isdbg('chan'); -- $conn->send_now("D$call|$mess"); -- sleep(2); -- $conn->disconnect; --} -- --sub error_handler --{ -- my $dxchan = shift; -- $dxchan->{conn}->set_error(undef) if exists $dxchan->{conn}; -- $dxchan->disconnect(1); --} -- --# handle incoming messages --sub new_channel --{ -- my ($conn, $msg) = @_; -- my ($sort, $call, $line) = DXChannel::decode_input(0, $msg); -- return unless defined $sort; -- -- unless (is_callsign($call)) { -- already_conn($conn, $call, DXM::msg($lang, "illcall", $call)); -- return; -- } -- -- # set up the basic channel info -- # is there one already connected to me - locally? -- my $user = DXUser->get_current($call); -- my $dxchan = DXChannel::get($call); -- if ($dxchan) { -- if ($user && $user->is_node) { -- already_conn($conn, $call, DXM::msg($lang, 'concluster', $call, $main::mycall)); -- return; -- } -- if ($bumpexisting) { -- my $ip = $conn->{peerhost} || 'unknown'; -- $dxchan->send_now('D', DXM::msg($lang, 'conbump', $call, $ip)); -- LogDbg('DXCommand', "$call bumped off by $ip, disconnected"); -- $dxchan->disconnect; -- } else { -- already_conn($conn, $call, DXM::msg($lang, 'conother', $call, $main::mycall)); -- return; -- } -- } -- -- # is he locked out ? -- my $basecall = $call; -- $basecall =~ s/-\d+$//; -- my $baseuser = DXUser->get_current($basecall); -- my $lock = $user->lockout if $user; -- if ($baseuser && $baseuser->lockout || $lock) { -- if (!$user || !defined $lock || $lock) { -- my $host = $conn->{peerhost} || "unknown"; -- LogDbg('DXCommand', "$call on $host is locked out, disconnected"); -- $conn->disconnect; -- return; -- } -- } -- -- if ($user) { -- $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems -- } else { -- $user = DXUser->new($call); -- } -- -- # create the channel -- if ($user->is_node) { -- $dxchan = DXProt->new($call, $conn, $user); -- } elsif ($user->is_user) { -- $dxchan = DXCommandmode->new($call, $conn, $user); -- } elsif ($user->is_bbs) { -- $dxchan = BBS->new($call, $conn, $user); -- } else { -- die "Invalid sort of user on $call = $sort"; -- } -- -- # check that the conn has a callsign -- $conn->conns($call) if $conn->isa('IntMsg'); -- -- # set callbacks -- $conn->set_error(sub {error_handler($dxchan)}); -- $conn->set_rproc(sub {my ($conn,$msg) = @_; $dxchan->rec($msg);}); -- $dxchan->rec($msg); --} -- -- --sub login --{ -- return \&new_channel; --} -- --# cease running this program, close down all the connections nicely --sub cease --{ -- my $dxchan; -- -- unless ($is_win) { -- $SIG{'TERM'} = 'IGNORE'; -- $SIG{'INT'} = 'IGNORE'; -- } -- -- DXUser::sync; -- -- eval { -- Local::finish(); # end local processing -- }; -- dbg("Local::finish error $@") if $@; -- -- # disconnect nodes -- foreach $dxchan (DXChannel::get_all_nodes) { -- $dxchan->disconnect(2) unless $dxchan == $main::me; -- } -- Msg->event_loop(100, 0.01); -- -- # disconnect users -- foreach $dxchan (DXChannel::get_all_users) { -- $dxchan->disconnect; -- } -- -- # disconnect AGW -- AGWMsg::finish(); -- -- # disconnect UDP customers -- UDPMsg::finish(); -- -- # end everything else -- Msg->event_loop(100, 0.01); -- DXUser::finish(); -- DXDupe::finish(); -- -- # close all databases -- DXDb::closeall; -- -- # close all listeners -- foreach my $l (@listeners) { -- $l->close_server; -- } -- -- LogDbg('cluster', "DXSpider V$version, build $build ended"); -- dbgclose(); -- Logclose(); -- -- $dbh->finish if $dbh; -- -- unlink $lockfn; --# $SIG{__WARN__} = $SIG{__DIE__} = sub {my $a = shift; cluck($a); }; -- exit(0); --} -- --# the reaper of children --sub reap --{ -- my $cpid; -- while (($cpid = waitpid(-1, WNOHANG)) > 0) { -- dbg("cpid: $cpid") if isdbg('reap'); --# Msg->pid_gone($cpid); -- $zombies-- if $zombies > 0; -- } -- dbg("cpid: $cpid") if isdbg('reap'); --} -- --# this is where the input queue is dealt with and things are dispatched off to other parts of --# the cluster -- --sub uptime --{ -- my $t = $systime - $starttime; -- my $days = int $t / 86400; -- $t -= $days * 86400; -- my $hours = int $t / 3600; -- $t -= $hours * 3600; -- my $mins = int $t / 60; -- return sprintf "%d %02d:%02d", $days, $hours, $mins; --} -- --sub AGWrestart --{ -- AGWMsg::init(\&new_channel); --} -- --############################################################# --# --# The start of the main line of code --# --############################################################# -- --$starttime = $systime = time; -$systime_days = int ($systime / 86400); -$systime_daystart = $systime_days * 86400; --$lang = 'en' unless $lang; -- --unless ($DB::VERSION) { -- $SIG{INT} = $SIG{TERM} = \&cease; --} -- --# open the debug file, set various FHs to be unbuffered --dbginit(\&DXCommandmode::broadcast_debug); --foreach (@debug) { -- dbgadd($_); --} --STDOUT->autoflush(1); -- --# try to load the database --if (DXSql::init($dsn)) { -- $dbh = DXSql->new($dsn); -- $dbh = $dbh->connect($dsn, $dbuser, $dbpass) if $dbh; -} - -# try to load Encode -{ - local $^W = 0; - my $w = $SIG{__DIE__}; - $SIG{__DIE__} = 'IGNORE'; - eval { require Encode; }; - unless ($@) { - import Encode; - $can_encode = 1; - } - $SIG{__DIE__} = $w; --} -- --# try to load XML::Simple --DXXml::init(); -- --# banner --my ($year) = (gmtime)[5]; --$year += 1900; --LogDbg('cluster', "DXSpider V$version, build $build started"); --dbg("Copyright (c) 1998-$year Dirk Koopman G1TLH"); -- --# load Prefixes --dbg("loading prefixes ..."); --dbg(USDB::init()); --my $r = Prefix::init(); --confess $r if $r; -- --# load band data --dbg("loading band data ..."); --Bands::load(); -- --# initialise User file system --dbg("loading user file system ..."); --DXUser->init($userfn, 1); -- --# look for the sysop and the alias user and complain if they aren't there --{ -- my $ref = DXUser->get($mycall); -- die "$mycall missing, run the create_sysop.pl script and please RTFM" unless $ref && $ref->priv == 9; -- $ref = DXUser->get($myalias); -- die "$myalias missing, run the create_sysop.pl script and please RTFM" unless $ref && $ref->priv == 9; --} -- --# start listening for incoming messages/connects --dbg("starting listeners ..."); --my $conn = IntMsg->new_server($clusteraddr, $clusterport, \&login); --$conn->conns("Server $clusteraddr/$clusterport using IntMsg"); --push @listeners, $conn; --dbg("Internal port: $clusteraddr $clusterport using IntMsg"); --foreach my $l (@main::listen) { -- no strict 'refs'; -- my $pkg = $l->[2] || 'ExtMsg'; -- my $login = $l->[3] || 'login'; -- -- $conn = $pkg->new_server($l->[0], $l->[1], \&{"${pkg}::${login}"}); -- $conn->conns("Server $l->[0]/$l->[1] using ${pkg}::${login}"); -- push @listeners, $conn; -- dbg("External Port: $l->[0] $l->[1] using ${pkg}::${login}"); --} -- --dbg("AGW Listener") if $AGWMsg::enable; --AGWrestart(); -- --dbg("UDP Listener") if $UDPMsg::enable; --UDPMsg::init(\&new_channel); -- --# load bad words --dbg("load badwords: " . (BadWords::load or "Ok")); -- --# prime some signals --unless ($DB::VERSION) { -- $SIG{INT} = $SIG{TERM} = sub { $decease = 1 }; --} -- --unless ($is_win) { -- $SIG{HUP} = 'IGNORE'; -- $SIG{CHLD} = sub { $zombies++ }; -- -- $SIG{PIPE} = sub { dbg("Broken PIPE signal received"); }; -- $SIG{IO} = sub { dbg("SIGIO received"); }; -- $SIG{WINCH} = $SIG{STOP} = $SIG{CONT} = 'IGNORE'; -- $SIG{KILL} = 'DEFAULT'; # as if it matters.... -- -- # catch the rest with a hopeful message -- for (keys %SIG) { -- if (!$SIG{$_}) { -- # dbg("Catching SIG $_") if isdbg('chan'); -- $SIG{$_} = sub { my $sig = shift; DXDebug::confess("Caught signal $sig"); }; -- } -- } --} -- --# start dupe system --dbg("Starting Dupe system"); --DXDupe::init(); -- --# read in system messages --dbg("Read in Messages"); --DXM->init(); -- --# read in command aliases --dbg("Read in Aliases"); --CmdAlias->init(); -- --# initialise the Geomagnetic data engine --dbg("Start WWV"); --Geomag->init(); --dbg("Start WCY"); --WCY->init(); -- --# initial the Spot stuff --dbg("Starting DX Spot system"); --Spot->init(); -- --# initialise the protocol engine --dbg("Start Protocol Engines ..."); --DXProt->init(); -- --# put in a DXCluster node for us here so we can add users and take them away --$routeroot = Route::Node->new($mycall, $version*100+5300, Route::here($main::me->here)|Route::conf($main::me->conf)); -$routeroot->do_pc9x(1); -$routeroot->via_pc92(1); -- --# make sure that there is a routing OUTPUT node default file --#unless (Filter::read_in('route', 'node_default', 0)) { --# my $dxcc = $main::me->dxcc; --# $Route::filterdef->cmd($main::me, 'route', 'accept', "node_default call $mycall" ); --#} -- --# read in any existing message headers and clean out old crap --dbg("reading existing message headers ..."); --DXMsg->init(); --DXMsg::clean_old(); -- --# read in any cron jobs --dbg("reading cron jobs ..."); --DXCron->init(); -- --# read in database descriptors --dbg("reading database descriptors ..."); --DXDb::load(); -- --# starting local stuff --dbg("doing local initialisation ..."); --QSL::init(1); --eval { -- Local::init(); --}; --dbg("Local::init error $@") if $@; -- --# this, such as it is, is the main loop! --dbg("orft we jolly well go ..."); --my $script = new Script "startup"; --$script->run($main::me) if $script; -- --#open(DB::OUT, "|tee /tmp/aa"); -- --for (;;) { --# $DB::trace = 1; -- -- Msg->event_loop(10, 0.010); -- my $timenow = time; -- -- DXChannel::process(); -- --# $DB::trace = 0; -- -- # do timed stuff, ongoing processing happens one a second -- if ($timenow != $systime) { -- reap() if $zombies; - IsoTime::update($systime = $timenow); - $systime = $timenow; - my $days = int ($systime / 86400); - if ($systime_days != $days) { - $systime_days = $days; - $systime_daystart = $days * 86400; - } - IsoTime::update($systime); -- DXCron::process(); # do cron jobs -- DXCommandmode::process(); # process ongoing command mode stuff -- DXXml::process(); -- DXProt::process(); # process ongoing ak1a pcxx stuff -- DXConnect::process(); -- DXMsg::process(); -- DXDb::process(); -- DXUser::process(); -- DXDupe::process(); -- AGWMsg::process(); -- -- eval { -- Local::process(); # do any localised processing -- }; -- dbg("Local::process error $@") if $@; -- } -- if ($decease) { -- last if --$decease <= 0; -- } --} --cease(0); --exit(0); -- -- ++#!/usr/bin/perl -w## This is the DX cluster 'daemon'. It sits in the middle of its little# web of client routines sucking and blowing data where it may.## Hence the name of 'spider' (although it may become 'dxspider')## Copyright (c) 1998 Dirk Koopman G1TLH## $Id$#require 5.004;# make sure that modules are searched in the order local then perlBEGIN { umask 002; # root of directory tree for this system $root = "/spider"; $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; unshift @INC, "$root/perl"; # this IS the right way round! unshift @INC, "$root/local"; # do some validation of the input die "The directory $root doesn't exist, please RTFM" unless -d $root; die "$root/local doesn't exist, please RTFM" unless -d "$root/local"; die "$root/local/DXVars.pm doesn't exist, please RTFM" unless -e "$root/local/DXVars.pm"; mkdir "$root/local_cmd", 0777 unless -d "$root/local_cmd"; # try to create and lock a lockfile (this isn't atomic but # should do for now $lockfn = "$root/local/cluster.lck"; # lock file name if (-e $lockfn) { open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!"; my $pid = ; chomp $pid; die "Lockfile ($lockfn) and process $pid exist, another cluster running?" if kill 0, $pid; close CLLOCK; } open(CLLOCK, ">$lockfn") or die "Can't open Lockfile ($lockfn) $!"; print CLLOCK "$$\n"; close CLLOCK; $is_win = ($^O =~ /^MS/ || $^O =~ /^OS-2/) ? 1 : 0; # is it Windows? $systime = time;}use DXVars;use Msg;use IntMsg;use Internet;use Listeners;use ExtMsg;use AGWConnect;use AGWMsg;use DXDebug;use DXLog;use DXLogPrint;use DXUtil;use DXChannel;use DXUser;use DXM;use DXCommandmode;use DXProtVars;use DXProtout;use DXProt;use DXMsg;use DXCron;use DXConnect;use DXBearing;use DXDb;use DXHash;use DXDupe;use Script;use Prefix;use Spot;use Bands;use Keps;use Minimuf;use Sun;use Geomag;use CmdAlias;use Filter;use AnnTalk;use BBS;use WCY;use BadWords;use Timer;use Route;use Route::Node;use Route::User;use Editable;use Mrtg;use USDB;use UDPMsg;use QSL;use RouteDB;use DXXml;use DXSql;use IsoTime;use Data::Dumper;use IO::File;use Fcntl ':flock';use POSIX ":sys_wait_h";use Version;use Local;package main;use strict;use vars qw(@inqueue $systime $starttime $lockfn @outstanding_connects $zombies $root @listeners $lang $myalias @debug $userfn $clusteraddr $clusterport $mycall $decease $is_win $routeroot $me $reqreg $bumpexisting $allowdxby $dbh $dsn $dbuser $dbpass $do_xml $systime_days $systime_daystart $can_encode );@inqueue = (); # the main input queue, an array of hashes$systime = 0; # the time now (in seconds)$starttime = 0; # the starting time of the cluster@outstanding_connects = (); # list of outstanding connects@listeners = (); # list of listeners$reqreg = 0; # 1 = registration required, 2 = deregister people$bumpexisting = 1; # 1 = allow new connection to disconnect old, 0 - don't allow it$allowdxby = 0; # 1 = allow "dx by ", 0 - don't allow it# send a message to call on conn and disconnectsub already_conn{ my ($conn, $call, $mess) = @_; $conn->disable_read(1); dbg("-> D $call $mess\n") if isdbg('chan'); $conn->send_now("D$call|$mess"); sleep(2); $conn->disconnect;}sub error_handler{ my $dxchan = shift; $dxchan->{conn}->set_error(undef) if exists $dxchan->{conn}; $dxchan->disconnect(1);}# handle incoming messagessub new_channel{ my ($conn, $msg) = @_; my ($sort, $call, $line) = DXChannel::decode_input(0, $msg); return unless defined $sort; unless (is_callsign($call)) { already_conn($conn, $call, DXM::msg($lang, "illcall", $call)); return; } # set up the basic channel info # is there one already connected to me - locally? my $user = DXUser->get_current($call); my $dxchan = DXChannel::get($call); if ($dxchan) { if ($user && $user->is_node) { already_conn($conn, $call, DXM::msg($lang, 'concluster', $call, $main::mycall)); return; } if ($bumpexisting) { my $ip = $conn->{peerhost} || 'unknown'; $dxchan->send_now('D', DXM::msg($lang, 'conbump', $call, $ip)); LogDbg('DXCommand', "$call bumped off by $ip, disconnected"); $dxchan->disconnect; } else { already_conn($conn, $call, DXM::msg($lang, 'conother', $call, $main::mycall)); return; } } # is he locked out ? my $basecall = $call; $basecall =~ s/-\d+$//; my $baseuser = DXUser->get_current($basecall); my $lock = $user->lockout if $user; if ($baseuser && $baseuser->lockout || $lock) { if (!$user || !defined $lock || $lock) { my $host = $conn->{peerhost} || "unknown"; LogDbg('DXCommand', "$call on $host is locked out, disconnected"); $conn->disconnect; return; } } if ($user) { $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems } else { $user = DXUser->new($call); } # create the channel if ($user->is_node) { $dxchan = DXProt->new($call, $conn, $user); } elsif ($user->is_user) { $dxchan = DXCommandmode->new($call, $conn, $user); } elsif ($user->is_bbs) { $dxchan = BBS->new($call, $conn, $user); } else { die "Invalid sort of user on $call = $sort"; } # check that the conn has a callsign $conn->conns($call) if $conn->isa('IntMsg'); # set callbacks $conn->set_error(sub {error_handler($dxchan)}); $conn->set_rproc(sub {my ($conn,$msg) = @_; $dxchan->rec($msg);}); $dxchan->rec($msg);}sub login{ return \&new_channel;}# cease running this program, close down all the connections nicelysub cease{ my $dxchan; unless ($is_win) { $SIG{'TERM'} = 'IGNORE'; $SIG{'INT'} = 'IGNORE'; } DXUser::sync; eval { Local::finish(); # end local processing }; dbg("Local::finish error $@") if $@; # disconnect nodes foreach $dxchan (DXChannel::get_all_nodes) { $dxchan->disconnect(2) unless $dxchan == $main::me; } Msg->event_loop(100, 0.01); # disconnect users foreach $dxchan (DXChannel::get_all_users) { $dxchan->disconnect; } # disconnect AGW AGWMsg::finish(); # disconnect UDP customers UDPMsg::finish(); # end everything else Msg->event_loop(100, 0.01); DXUser::finish(); DXDupe::finish(); # close all databases DXDb::closeall; # close all listeners foreach my $l (@listeners) { $l->close_server; } LogDbg('cluster', "DXSpider V$version, build $build ended"); dbgclose(); Logclose(); $dbh->finish if $dbh; unlink $lockfn;# $SIG{__WARN__} = $SIG{__DIE__} = sub {my $a = shift; cluck($a); }; exit(0);}# the reaper of childrensub reap{ my $cpid; while (($cpid = waitpid(-1, WNOHANG)) > 0) { dbg("cpid: $cpid") if isdbg('reap');# Msg->pid_gone($cpid); $zombies-- if $zombies > 0; } dbg("cpid: $cpid") if isdbg('reap');}# this is where the input queue is dealt with and things are dispatched off to other parts of# the clustersub uptime{ my $t = $systime - $starttime; my $days = int $t / 86400; $t -= $days * 86400; my $hours = int $t / 3600; $t -= $hours * 3600; my $mins = int $t / 60; return sprintf "%d %02d:%02d", $days, $hours, $mins;}sub AGWrestart{ AGWMsg::init(\&new_channel);}############################################################### The start of the main line of code##############################################################$starttime = $systime = time;$systime_days = int ($systime / 86400);$systime_daystart = $systime_days * 86400;$lang = 'en' unless $lang;unless ($DB::VERSION) { $SIG{INT} = $SIG{TERM} = \&cease;}# open the debug file, set various FHs to be unbuffereddbginit(\&DXCommandmode::broadcast_debug);foreach (@debug) { dbgadd($_);}STDOUT->autoflush(1);# try to load the databaseif (DXSql::init($dsn)) { $dbh = DXSql->new($dsn); $dbh = $dbh->connect($dsn, $dbuser, $dbpass) if $dbh;}# try to load Encode{ local $^W = 0; my $w = $SIG{__DIE__}; $SIG{__DIE__} = 'IGNORE'; eval { require Encode; }; unless ($@) { import Encode; $can_encode = 1; } $SIG{__DIE__} = $w;}# try to load XML::SimpleDXXml::init();# bannermy ($year) = (gmtime)[5];$year += 1900;LogDbg('cluster', "DXSpider V$version, build $build started");dbg("Copyright (c) 1998-$year Dirk Koopman G1TLH");# load Prefixesdbg("loading prefixes ...");dbg(USDB::init());my $r = Prefix::init();confess $r if $r;# load band datadbg("loading band data ...");Bands::load();# initialise User file systemdbg("loading user file system ...");DXUser->init($userfn, 1);# look for the sysop and the alias user and complain if they aren't there{ my $ref = DXUser->get($mycall); die "$mycall missing, run the create_sysop.pl script and please RTFM" unless $ref && $ref->priv == 9; $ref = DXUser->get($myalias); die "$myalias missing, run the create_sysop.pl script and please RTFM" unless $ref && $ref->priv == 9;}# start listening for incoming messages/connectsdbg("starting listeners ...");my $conn = IntMsg->new_server($clusteraddr, $clusterport, \&login);$conn->conns("Server $clusteraddr/$clusterport using IntMsg");push @listeners, $conn;dbg("Internal port: $clusteraddr $clusterport using IntMsg");foreach my $l (@main::listen) { no strict 'refs'; my $pkg = $l->[2] || 'ExtMsg'; my $login = $l->[3] || 'login'; $conn = $pkg->new_server($l->[0], $l->[1], \&{"${pkg}::${login}"}); $conn->conns("Server $l->[0]/$l->[1] using ${pkg}::${login}"); push @listeners, $conn; dbg("External Port: $l->[0] $l->[1] using ${pkg}::${login}");}dbg("AGW Listener") if $AGWMsg::enable;AGWrestart();dbg("UDP Listener") if $UDPMsg::enable;UDPMsg::init(\&new_channel);# load bad wordsdbg("load badwords: " . (BadWords::load or "Ok"));# prime some signalsunless ($DB::VERSION) { $SIG{INT} = $SIG{TERM} = sub { $decease = 1 };}unless ($is_win) { $SIG{HUP} = 'IGNORE'; $SIG{CHLD} = sub { $zombies++ }; $SIG{PIPE} = sub { dbg("Broken PIPE signal received"); }; $SIG{IO} = sub { dbg("SIGIO received"); }; $SIG{WINCH} = $SIG{STOP} = $SIG{CONT} = 'IGNORE'; $SIG{KILL} = 'DEFAULT'; # as if it matters.... # catch the rest with a hopeful message for (keys %SIG) { if (!$SIG{$_}) { # dbg("Catching SIG $_") if isdbg('chan'); $SIG{$_} = sub { my $sig = shift; DXDebug::confess("Caught signal $sig"); }; } }}# start dupe systemdbg("Starting Dupe system");DXDupe::init();# read in system messagesdbg("Read in Messages");DXM->init();# read in command aliasesdbg("Read in Aliases");CmdAlias->init();# initialise the Geomagnetic data enginedbg("Start WWV");Geomag->init();dbg("Start WCY");WCY->init();# initial the Spot stuffdbg("Starting DX Spot system");Spot->init();# initialise the protocol enginedbg("Start Protocol Engines ...");DXProt->init();# put in a DXCluster node for us here so we can add users and take them away$routeroot = Route::Node->new($mycall, $version*100+5300, Route::here($main::me->here)|Route::conf($main::me->conf));$routeroot->do_pc9x(1);$routeroot->via_pc92(1);# make sure that there is a routing OUTPUT node default file#unless (Filter::read_in('route', 'node_default', 0)) {# my $dxcc = $main::me->dxcc;# $Route::filterdef->cmd($main::me, 'route', 'accept', "node_default call $mycall" );#}# read in any existing message headers and clean out old crapdbg("reading existing message headers ...");DXMsg->init();DXMsg::clean_old();# read in any cron jobsdbg("reading cron jobs ...");DXCron->init();# read in database descriptorsdbg("reading database descriptors ...");DXDb::load();# starting local stuffdbg("doing local initialisation ...");QSL::init(1);eval { Local::init();};dbg("Local::init error $@") if $@;# this, such as it is, is the main loop!dbg("orft we jolly well go ...");my $script = new Script "startup";$script->run($main::me) if $script;#open(DB::OUT, "|tee /tmp/aa");for (;;) {# $DB::trace = 1; Msg->event_loop(10, 0.010); my $timenow = time; DXChannel::process();# $DB::trace = 0; # do timed stuff, ongoing processing happens one a second if ($timenow != $systime) { reap() if $zombies; $systime = $timenow; my $days = int ($systime / 86400); if ($systime_days != $days) { $systime_days = $days; $systime_daystart = $days * 86400; } IsoTime::update($systime); DXCron::process(); # do cron jobs DXCommandmode::process(); # process ongoing command mode stuff DXXml::process(); DXProt::process(); # process ongoing ak1a pcxx stuff DXConnect::process(); DXMsg::process(); DXDb::process(); DXUser::process(); DXDupe::process(); AGWMsg::process(); eval { Local::process(); # do any localised processing }; dbg("Local::process error $@") if $@; } if ($decease) { last if --$decease <= 0; }}cease(0);exit(0);