]> www.dxcluster.org Git - spider.git/commitdiff
recover from removal of newline characters! SIMPLEROUTE origin/SIMPLEROUTE
authorDirk Koopman <djk@tobit.co.uk>
Thu, 21 Jun 2007 14:38:09 +0000 (15:38 +0100)
committerDirk Koopman <djk@tobit.co.uk>
Thu, 21 Jun 2007 14:40:45 +0000 (15:40 +0100)
perl/DXProt.pm
perl/DXProtHandle.pm
perl/DXProtVars.pm
perl/DXProtout.pm
perl/Route.pm
perl/Route/Node.pm
perl/Version.pm
perl/cluster.pl

index ca17f4a6430cd8d0cfd4c31e020c7c5001b7b362..685678083a9240a65225d9627c4384ad342082dd 100644 (file)
@@ -1 +1,1532 @@
-#!/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$//; $_ } <MSG>;         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__
\ No newline at end of file
+#!/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 announce
+sub 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 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 = 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 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);
+
+       # 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 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$//; $_ } <MSG>;
+               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__
index d38067eee691f9f565d31cb7dca69e670ca8397b..b5d7568a2bcce44a92a42dd9b0e745597c69fd35 100644 (file)
@@ -1 +1,1804 @@
-### 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 <call>' 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;
\ No newline at end of file
+#
+#
+# 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 <call>' 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;
index 9f839b23163cc5961bf1ea08869e38d1bd522748..a5f6bc433b677fc3ac126e105fe56c578e97eb3c 100644 (file)
@@ -1 +1,50 @@
-### 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;
\ No newline at end of file
+#
+#
+# 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;
index 27b7a4c98dbd74a4df89e57a171f1580ae45ae2d..5f1664d0a2646c2e8047133e5a5ca9f0c5fa3975 100644 (file)
@@ -1 +1,455 @@
-#!/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__
\ No newline at end of file
+#!/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 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 = " 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 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__
+
+
+
index 2ffd1f2b8e4a4a852e05077d6520a9cc61723bf1..cf4eb198e9d664746fb8920717571ceffee79f27 100644 (file)
@@ -1 +1,391 @@
-#!/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;
\ No newline at end of file
+#!/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 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;
index 6181e2d819e60fd7e6b27ad01f9985f95a33f4de..e17b01f8858feaf4aee5f965c71bb6bf79fbf48a 100644 (file)
@@ -1 +1,376 @@
-## 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;
\ No newline at end of file
+#
+# 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 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 || 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;
+
index 8a47ecede431e87a6e53dce0c96c4b4d1dcddc60..ecfc658c872db53032d5291b771f2c4b8b4fada5 100644 (file)
@@ -10,6 +10,6 @@ package main;
 use vars qw($version $build);
 
 $version = '1.54';
 use vars qw($version $build);
 
 $version = '1.54';
-$build = '56';
+$build = '57';
 
 1;
 
 1;
index 9534adadeb504749f791670ea33f9125323d15d6..80bedb460e5b3526b656b5ee0260a1bfa17c5e85 100755 (executable)
@@ -1 +1,549 @@
-#!/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 = <CLLOCK>;             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 <othercall>", 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);
\ No newline at end of file
+#!/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 = <CLLOCK>;
+               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 <othercall>", 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;
+               $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);
+
+