From: minima Date: Wed, 6 Jun 2001 13:30:21 +0000 (+0000) Subject: add more routing code together with associated commands X-Git-Tag: OLDROUTE_1_48~8 X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=b67b50de92dbf61ce939b42f7c74e30dc58eba41;p=spider.git add more routing code together with associated commands --- diff --git a/Changes b/Changes index 815fe1fc..b17e22fc 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,13 @@ +06Jun01======================================================================= +1. add stat/route_node and stat/route_user commands +05Jun01======================================================================= +1. add set/bbs command +2. more work on Routing code. +3. status/msg on its own will print the status of the msg system. +4. add sh/newconfig command +03Jun01======================================================================= +1. Fix the problem with ExtMsg and unresolvable IP addresses, hopefully +properly this time. 15May01======================================================================= 1. set/lockout now prevents any outgoing connection taking place. 2. Started the new routing stuff which will run in parallel for a while. diff --git a/cmd/Commands_en.hlp b/cmd/Commands_en.hlp index 8765a69b..eaef20c9 100644 --- a/cmd/Commands_en.hlp +++ b/cmd/Commands_en.hlp @@ -983,6 +983,8 @@ Use with extreme care. This command may well be superceded by FILTERing. === 0^SET/BEEP^Add a beep to DX and other messages on your terminal === 0^UNSET/BEEP^Stop beeps for DX and other messages on your terminal +=== 5^SET/BBS [..]^Make the callsign a BBS + === 5^SET/CLX [..]^Make the callsign an CLX node === 9^SET/DEBUG ^Add a debug level to the debug set @@ -1520,10 +1522,18 @@ you are on or else for the callsign that you asked for. Only the fields that are defined (in perl term) will be displayed. +=== 1^STAT/MSG^Show the status of the message system === 1^STAT/MSG ^Show the status of a message This command shows the internal status of a message and includes information such as to whom it has been forwarded, its size, origin etc etc. +If no message number is given then the status of the message system is +displayed. + +=== 5^STAT/ROUTE_NODE ^Show the data in a Route::Node object + +=== 5^STAT/ROUTE_USER ^Show the data in a Route::User object + === 5^STAT/USER []^Show the full status of a user Shows the full contents of a user record including all the secret flags and stuff. diff --git a/cmd/set/bbs.pl b/cmd/set/bbs.pl new file mode 100644 index 00000000..0cb6cf39 --- /dev/null +++ b/cmd/set/bbs.pl @@ -0,0 +1,39 @@ +# +# set user type to 'B' for BBS node +# +# Please note that this is only effective if the user is not on-line +# +# Copyright (c) 2001 - Dirk Koopman +# +# $Id$ +# + +my ($self, $line) = @_; +my @args = split /\s+/, $line; +my $call; +my @out; +my $user; +my $create; + +return (1, $self->msg('e5')) if $self->priv < 5; + +foreach $call (@args) { + $call = uc $call; + my $chan = DXChannel->get($call); + if ($chan) { + push @out, $self->msg('nodee1', $call); + } else { + $user = DXUser->get($call); + $create = !$user; + $user = DXUser->new($call) if $create; + if ($user) { + $user->sort('B'); + $user->homenode($call); + $user->close(); + push @out, $self->msg($create ? 'nodecc' : 'nodec', $call); + } else { + push @out, $self->msg('e3', "Set BBS", $call); + } + } +} +return (1, @out); diff --git a/cmd/set/clx.pl b/cmd/set/clx.pl index 954a6655..ba38b826 100644 --- a/cmd/set/clx.pl +++ b/cmd/set/clx.pl @@ -1,5 +1,5 @@ # -# set user type to 'S' for Spider node +# set user type to 'C' for CLX node # # Please note that this is only effective if the user is not on-line # diff --git a/cmd/show/newconfiguration.pl b/cmd/show/newconfiguration.pl new file mode 100644 index 00000000..a2599b88 --- /dev/null +++ b/cmd/show/newconfiguration.pl @@ -0,0 +1,21 @@ +# +# show the new style cluster routing tables to the user +# +# Copyright (c) 2001 Dirk Koopman G1TLH +# +# $Id$ +# + +my ($self, $line) = @_; +my @list = map { uc } split /\s+/, $line; # list of callsigns of nodes +my @out; +my $nodes_only; + +if (@list && $list[0] =~ /^NOD/) { + $nodes_only++; + shift @list; +} + +push @out, $main::routeroot->config($nodes_only, 0, @list); +return (1, @out); + diff --git a/cmd/show/qrz.pl b/cmd/show/qrz.pl index 910b1997..6779db42 100644 --- a/cmd/show/qrz.pl +++ b/cmd/show/qrz.pl @@ -29,7 +29,7 @@ foreach $l (@list) { Log('call', "$call: show/qrz \U$l"); my $state = "blank"; while (my $result = $t->getline) { -# print $result; + dbg('qrz', $result); if ($state eq 'blank' && $result =~ /^\s*Callsign\s*:/i) { $state = 'go'; } elsif ($state eq 'go') { diff --git a/cmd/stat/msg.pl b/cmd/stat/msg.pl index 5c5b46a0..2b7ed752 100644 --- a/cmd/stat/msg.pl +++ b/cmd/stat/msg.pl @@ -9,16 +9,32 @@ my @list = split /\s+/, $line; # generate a list of msg nos my @out; return (1, $self->msg('e5')) if $self->priv < 1; -return (1, $self->msg('m16')) if @list == 0; -foreach my $msgno (@list) { - my $ref = DXMsg::get($msgno); - if ($ref) { - @out = print_all_fields($self, $ref, "Msg Parameters $msgno"); - } else { - push @out, $self->msg('m4', $msgno); - } - push @out, "" if @list > 1; +if (@list == 0) { + my $ref; + push @out, "Work Queue Keys"; + push @out, map { " $_" } sort keys %DXMsg::work; + push @out, "Busy Queue Data"; + foreach $ref (sort {$a->call cmp $b->call} DXMsg::get_all_busy) { + my $msgno = $ref->msgno; + my $stream = $ref->stream; + my $lines = scalar $ref->lines; + my $count = $ref->count; + my $lastt = $ref->lastt ? " Last Processed: " . cldatetime($ref->lastt) : ""; + my $waitt = $ref->waitt ? " Waiting since: " . cldatetime($ref->waitt) : ""; + + push @out, " $call -> msg: $msgno stream: $stream Count: $count Lines: $lines$lastt$waitt"; + } +} else { + foreach my $msgno (@list) { + my $ref = DXMsg::get($msgno); + if ($ref) { + @out = print_all_fields($self, $ref, "Msg Parameters $msgno"); + } else { + push @out, $self->msg('m4', $msgno); + } + push @out, "" if @list > 1; + } } return (1, @out); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 7602283f..8a300d5f 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -92,6 +92,7 @@ $count = 0; cluster => '5,Cluster data', isbasic => '9,Internal Connection', errors => '9,Errors', + route => '9,Route Data', ); # object destruction diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 967cc022..0f80232a 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -103,6 +103,11 @@ sub start my $cuser = DXNodeuser->new($self, $node, $call, 0, 1); $node->dxchan($self) if $call eq $main::myalias; # send all output for mycall to myalias + # routing version + my $pref = Route::Node::get($main::mycall) or die "$main::mycall not allocated in Route database"; + $pref->add_user($call, Route::here($self->{here})); + dbg('route', "B/C PC16 on $main::mycall for: $call"); + # issue a pc16 to everybody interested my $nchan = DXChannel->get($main::mycall); my @pc16 = DXProt::pc16($nchan, $cuser); @@ -411,6 +416,12 @@ sub disconnect $node->dxchan($DXProt::me); } + my $pref = Route::Node::get($main::mycall); + if ($pref) { + my @rout = $pref->del_user($main::mycall); + dbg('route', "B/C PC17 on $main::mycall for: $call"); + } + # I was the last node visited $self->user->node($main::mycall); diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm index 790b398d..766dacbd 100644 --- a/perl/DXDebug.pm +++ b/perl/DXDebug.pm @@ -11,14 +11,14 @@ package DXDebug; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(dbginit dbgstore dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck cluck); +@EXPORT = qw(dbginit dbgstore dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck); use strict; use vars qw(%dbglevel $fp); use DXUtil; use DXLog (); -use Carp qw(cluck); +use Carp (); %dbglevel = (); $fp = undef; @@ -44,7 +44,8 @@ if (!defined $DB::VERSION) { CORE::die(Carp::shortmess($@)) if $@; } else { eval qq( sub confess { Carp::confess(\@_); }; - sub cluck { Carp::cluck(\@_); }; + sub croak { Carp::croak(\@_); }; + sub cluck { Carp::cluck(\@_); }; ); } diff --git a/perl/DXProt.pm b/perl/DXProt.pm index decd71f6..6fcf0289 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -31,6 +31,7 @@ use WCY; use Time::HiRes qw(gettimeofday tv_interval); use BadWords; use DXHash; +use Route; use Route::Node; use strict; @@ -181,7 +182,7 @@ sub init confess $@ if $@; $me->{sort} = 'S'; # S for spider $me->{priv} = 9; - $Route::Node::me->adddxchan($me); +# $Route::Node::me->adddxchan($me); } # @@ -250,6 +251,7 @@ sub start # send info to all logged in thingies $self->tell_login('loginn'); + $main::routeroot->add($call); Log('DXProt', "$call connected"); } @@ -514,16 +516,9 @@ sub normal } if ($pcno == 16) { # add a user - my $node = DXCluster->get_exact($field[1]); + + # general checks my $dxchan; - if (!$node && ($dxchan = DXChannel->get($field[1]))) { - # add it to the node table if it isn't present and it's - # connected locally - $node = DXNode->new($dxchan, $field[1], 0, 1, 5400); - dbg('chan', "PCPROT: $field[1] no PC19 yet, autovivified as node"); -# broadcast_ak1a(pc19($dxchan, $node), $dxchan, $self) unless $dxchan->{isolate}; - - } if ($field[1] eq $main::mycall || $field[2] eq $main::mycall) { dbg('chan', "PCPROT: trying to alter config on this node from outside!"); return; @@ -532,50 +527,68 @@ sub normal dbg('chan', "PCPROT: trying to connect sysop from outside!"); return; } + if (($dxchan = DXChannel->get($field[1])) && $dxchan != $self) { + dbg('chan', "PCPROT: $field[1] connected locally"); + return; + } + + my $node = DXCluster->get_exact($field[1]); unless ($node) { dbg('chan', "PCPROT: Node $field[1] not in config"); return; } + my $pref = Route::Node::get($field[1]); + unless ($pref) { + dbg('chan', "PCPROT: Route::Node $field[1] not in config"); + return; + } + my $wrong; unless ($node->isa('DXNode')) { dbg('chan', "PCPROT: $field[1] is not a node"); - return; + $wrong = 1; } if ($node->dxchan != $self) { dbg('chan', "PCPROT: $field[1] came in on wrong channel"); - return; - } - if (($dxchan = DXChannel->get($field[1])) && $dxchan != $self) { - dbg('chan', "PCPROT: $field[1] connected locally"); - return; + $wrong = 1; } my $i; - + my @rout; for ($i = 2; $i < $#field; $i++) { my ($call, $confmode, $here) = $field[$i] =~ /^(\S+) (\S) (\d)/o; next unless $call && $confmode && defined $here && is_callsign($call); - my $ref = DXCluster->get_exact($call); - if ($ref) { - if ($ref->isa('DXNode')) { - dbg('chan', "PCPROT: $call is a node"); + $confmode = $confmode eq '*'; + + push @rout, $pref->add_user($call, Route::here($here)|Route::conf($confmode)); + + unless ($wrong) { + my $ref = DXCluster->get_exact($call); + if ($ref) { + if ($ref->isa('DXNode')) { + dbg('chan', "PCPROT: $call is a node"); + next; + } + my $rcall = $ref->mynode->call; + dbg('chan', "PCPROT: already have $call on $rcall"); next; } - my $rcall = $ref->mynode->call; - dbg('chan', "PCPROT: already have $call on $rcall"); - next; + + DXNodeuser->new($self, $node, $call, $confmode, $here); + + # 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($node->call) if !$user->homenode; + $user->node($node->call); + $user->lastin($main::systime) unless DXChannel->get($call); + $user->put; } - - $confmode = $confmode eq '*'; - DXNodeuser->new($self, $node, $call, $confmode, $here); - - # 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($node->call) if !$user->homenode; - $user->node($node->call); - $user->lastin($main::systime) unless DXChannel->get($call); - $user->put; } + + dbg('route', "B/C PC16 on $field[1] for: " . join(',', map{$_->call} @rout)) if @rout; + + # all these 'wrong' is just while we are swopping over to the Route stuff + return if $wrong; # queue up any messages (look for privates only) DXMsg::queue_msg(1) if $self->state eq 'normal'; @@ -585,15 +598,7 @@ sub normal } if ($pcno == 17) { # remove a user - my $node = DXCluster->get_exact($field[2]); my $dxchan; - if (!$node && ($dxchan = DXChannel->get($field[2]))) { - # add it to the node table if it isn't present and it's - # connected locally - $node = DXNode->new($dxchan, $field[2], 0, 1, 5400); - dbg('chan', "PCPROT: $field[2] no PC19 yet, autovivified as node"); -# broadcast_ak1a(pc19($dxchan, $node), $dxchan, $self) unless $dxchan->{isolate}; - } if ($field[1] eq $main::mycall || $field[2] eq $main::mycall) { dbg('chan', "PCPROT: trying to alter config on this node from outside!"); return; @@ -602,6 +607,20 @@ sub normal dbg('chan', "PCPROT: trying to disconnect sysop from outside!"); return; } + if ($dxchan = DXChannel->get($field[1])) { + dbg('chan', "PCPROT: $field[1] connected locally"); + return; + } + + my $pref = Route::Node::get($field[2]); + unless ($pref) { + dbg('chan', "PCPROT: Route::Node $field[2] not in config"); + return; + } + $pref->del_user($field[1]); + dbg('route', "B/C PC17 on $field[2] for: $field[1]"); + + my $node = DXCluster->get_exact($field[2]); unless ($node) { dbg('chan', "PCPROT: Node $field[2] not in config"); return; @@ -614,10 +633,6 @@ sub normal dbg('chan', "PCPROT: $field[2] came in on wrong channel"); return; } - if ($dxchan = DXChannel->get($field[1])) { - dbg('chan', "PCPROT: $field[1] connected locally"); - return; - } my $ref = DXCluster->get_exact($field[1]); if ($ref) { if ($ref->mynode != $node) { @@ -652,34 +667,58 @@ sub normal if ($pcno == 19) { # incoming cluster list my $i; my $newline = "PC19^"; + + # new routing list + my @rout; + my $pref = Route::Node::get($self->{call}); + + # parse the PC19 for ($i = 1; $i < $#field-1; $i += 4) { my $here = $field[$i]; my $call = uc $field[$i+1]; my $confmode = $field[$i+2]; my $ver = $field[$i+3]; next unless defined $here && defined $confmode && is_callsign($call); + # check for sane parameters + $ver = 5000 if $ver eq '0000'; + next if $ver < 5000; # only works with version 5 software + next if length $call < 3; # min 3 letter callsigns - $ver = 5400 if !$ver && $allowzero; # now check the call over my $node = DXCluster->get_exact($call); if ($node) { my $dxchan; - if (($dxchan = DXChannel->get($call)) && $dxchan != $self) { + if ((my $dxchan = DXChannel->get($call)) && $dxchan != $self) { dbg('chan', "PCPROT: $call connected locally"); } if ($node->dxchan != $self) { dbg('chan', "PCPROT: $call come in on wrong channel"); next; } + + # add a route object + if ($call eq $pref->call && !$pref->version) { + $pref->version($ver); + $pref->flags(Route::here($here)|Route::conf($confmode)); + } else { + my $r = $pref->add($call, $ver, Route::here($here)|Route::conf($confmode)); + push @rout, $r if $r; + } + my $rcall = $node->mynode->call; dbg('chan', "PCPROT: already have $call on $rcall"); next; } - - # check for sane parameters - next if $ver < 5000; # only works with version 5 software - next if length $call < 3; # min 3 letter callsigns + + # add a route object + if ($call eq $pref->call && !$pref->version) { + $pref->version($ver); + $pref->flags(Route::here($here)|Route::conf($confmode)); + } else { + my $r = $pref->add($call, $ver, Route::here($here)|Route::conf($confmode)); + push @rout, $r if $r; + } # add it to the nodes table and outgoing line $newline .= "$here^$call^$confmode^$ver^"; @@ -702,6 +741,8 @@ sub normal $user->lastin($main::systime) unless DXChannel->get($call); $user->put; } + + dbg('route', "B/C PC19 for: " . join(',', map{$_->call} @rout)) if @rout; return if $newline eq "PC19^"; @@ -720,26 +761,36 @@ sub normal if ($pcno == 21) { # delete a cluster from the list my $call = uc $field[1]; + my @rout; + my $pref = Route::Node::get($call); + if ($call ne $main::mycall) { # don't allow malicious buggers to disconnect me! + if ($call eq $self->{call}) { + dbg('chan', "PCPROT: Trying to disconnect myself with PC21"); + return; + } + if (my $dxchan = DXChannel->get($call)) { + dbg('chan', "PCPROT: $call connected locally"); + return; + } + + # routing objects + if ($pref) { + push @rout, $pref->del_node($call); + } else { + dbg('chan', "PCPROT: Route::Node $call not in config"); + } + my $node = DXCluster->get_exact($call); if ($node) { unless ($node->isa('DXNode')) { dbg('chan', "PCPROT: $call is not a node"); return; } - if ($call eq $self->{call}) { - dbg('chan', "PCPROT: Trying to disconnect myself with PC21"); - return; - } if ($node->dxchan != $self) { dbg('chan', "PCPROT: $call come in on wrong channel"); return; } - my $dxchan; - if ($dxchan = DXChannel->get($call)) { - dbg('chan', "PCPROT: $call connected locally"); - return; - } $node->del(); } else { dbg('chan', "PCPROT: $call not in table, dropped"); @@ -749,6 +800,8 @@ sub normal dbg('chan', "PCPROT: I WILL _NOT_ be disconnected!"); return; } + dbg('route', "B/C PC21 for: " . join(',', (map{$_->call} @rout))) if @rout; + # broadcast_route($line, $self, $call); # return; last SWITCH; @@ -1710,6 +1763,12 @@ sub disconnect $self->send_now("D", DXProt::pc39($main::mycall, $self->msg('disc1', "System Op"))); } + # do routing stuff + my $pref = Route::Node::get($self->{call}); + my @rout = $pref->del_nodes; + push @rout, $main::routeroot->del_node($call); + dbg('route', "B/C PC21 (from PC39) for: " . join(',', (map{ $_->call } @rout))) if @rout; + # unbusy and stop and outgoing mail my $mref = DXMsg::get_busy($call); $mref->stop_msg($call) if $mref; diff --git a/perl/DXProtVars.pm b/perl/DXProtVars.pm index ce256e1e..a5f6bc43 100644 --- a/perl/DXProtVars.pm +++ b/perl/DXProtVars.pm @@ -11,12 +11,6 @@ package DXProt; -# maximum number of users in a PC16 message -$pc16_max_users = 5; - -# maximum number of nodes in a PC19 message -$pc19_max_nodes = 5; - # the interval between pc50s (in seconds) $pc50_interval = 14*60; diff --git a/perl/DXProtout.pm b/perl/DXProtout.pm index 42c99551..1ebb29bc 100644 --- a/perl/DXProtout.pm +++ b/perl/DXProtout.pm @@ -80,7 +80,7 @@ sub pc16 for ($i = 0; @_; ) { my $str = "PC16^$self->{call}"; - for ( ; @_ && $i < $DXProt::pc16_max_users; $i++) { + for ( ; @_ && length $str < 200; $i++) { my $ref = shift; $str .= sprintf "^%s %s %d", $ref->call, $ref->confmode ? '*' : '-', $ref->here; } @@ -117,7 +117,7 @@ sub pc19 for ($i = 0; @_; ) { my $str = "PC19"; - for (; @_ && $i < $DXProt::pc19_max_nodes; $i++) { + for (; @_ && length $str < 200; $i++) { my $ref = shift; my $here = $ref->{here} ? '1' : '0'; my $confmode = $ref->{confmode} ? '1' : '0'; diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 0b3de951..b635e981 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -15,7 +15,7 @@ use Data::Dumper; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf - parray parraypairs shellregex readfilestr writefilestr + parray parraypairs phex shellregex readfilestr writefilestr print_all_fields cltounix unpad is_callsign is_freq is_digits is_pctext is_pcflag insertitem deleteitem ); @@ -141,6 +141,13 @@ sub promptf return ($priv, $prompt); } +# turn a hex field into printed hex +sub phex +{ + my $val = shift; + return sprintf '%X', $val; +} + # take an arg as an array list and print it sub parray { diff --git a/perl/Messages b/perl/Messages index cdeb2ee1..a9a1be91 100644 --- a/perl/Messages +++ b/perl/Messages @@ -159,6 +159,8 @@ package DXM; name => 'Your name is now \"$_[0]\"', nodea => '$_[0] set as AK1A style Node', nodeac => '$_[0] created as AK1A style Node', + nodeb => '$_[0] set as BBS', + nodebc => '$_[0] created as BBS', nodec => '$_[0] set as CLX style Node', nodecc => '$_[0] created as CLX style Node', noder => '$_[0] set as AR-Cluster style Node', diff --git a/perl/Route.pm b/perl/Route.pm index 2e90703e..a9c52170 100644 --- a/perl/Route.pm +++ b/perl/Route.pm @@ -22,13 +22,16 @@ use vars qw(%list %valid); %valid = ( call => "0,Callsign", + flags => "0,Flags,phex", ); sub new { my ($pkg, $call) = @_; - dbg('route', "$pkg created $call"); - return bless {call => $call}, $pkg; + + dbg('routelow', "create " . (ref($pkg) || $pkg) ." with $call"); + + return bless {call => $call}, (ref $pkg || $pkg); } # @@ -57,9 +60,10 @@ sub _addlist my $call = _getcall($c); unless (grep {$_ eq $call} @{$self->{$field}}) { push @{$self->{$field}}, $call; - dbg('route', ref($self) . " adding $call to " . $self->{call} . "->\{$field\}"); + dbg('routelow', ref($self) . " adding $call to " . $self->{call} . "->\{$field\}"); } } + return $self->{$field}; } sub _dellist @@ -70,9 +74,96 @@ sub _dellist my $call = _getcall($c); if (grep {$_ eq $call} @{$self->{$field}}) { $self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ]; - dbg('route', ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}"); + dbg('routelow', ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}"); } } + return $self->{$field}; +} + +# +# flag field constructors/enquirers +# + +sub here +{ + my $self = shift; + my $r = shift; + return $self ? 2 : 0 unless ref $self; + return $self->{flags} & 2 unless $r; + $self->{flags} = (($self->{flags} & ~2) | ($r ? 2 : 0)); + return $r; +} + +sub conf +{ + my $self = shift; + my $r = shift; + return $self ? 1 : 0 unless ref $self; + return $self->{flags} & 1 unless $r; + $self->{flags} = (($self->{flags} & ~1) | ($r ? 1 : 0)); + return $r; +} + +# +# 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 @out; + my $line; + my $call = $self->user_call; + + $line = ' ' x ($level*2) . "$call"; + $call = ' ' x length $call; + 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->"; + } + } + } + } + $line =~ s/->$//g; + $line =~ s/\s+$//; + push @out, $line if length $line; + + foreach my $ncall (sort @{$self->{nodes}}) { + my $nref = Route::Node::get($ncall); + next if @_ && !grep $ncall =~ m|$_|, @_; + + if ($nref) { + my $c = $nref->user_call; + push @out, $nref->config($nodes_only, $level+1, @_); + } else { + push @out, ' ' x (($level+1)*2) . "$ncall?"; + } + } + + return @out; } # @@ -84,7 +175,7 @@ sub DESTROY my $self = shift; my $pkg = ref $self; - dbg('route', "$pkg $self->{call} destroyed"); + dbg('routelow', "$pkg $self->{call} destroyed"); } no strict; @@ -95,7 +186,8 @@ no strict; sub fields { my $pkg = shift; - my @out, keys %pkg::valid if ref $pkg; + $pkg = ref $pkg if ref $pkg; + my @out, keys %$pkg::valid; push @out, keys %valid; return @out; } @@ -117,14 +209,15 @@ sub field_prompt sub AUTOLOAD { my $self = shift; - my ($pkg, $name) = $AUTOLOAD =~ /^(.*)::([^:]*)$/; - return if $name eq 'DESTROY'; + my $name = $AUTOLOAD; + return if $name =~ /::DESTROY$/; + $name =~ s/.*:://o; - confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $pkg::valid{$name}; + 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}} ; +# *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; @_ ? $self->{$name} = shift : $self->{$name} ; } diff --git a/perl/Route/Node.pm b/perl/Route/Node.pm index 2fee0acd..9e1f3c04 100644 --- a/perl/Route/Node.pm +++ b/perl/Route/Node.pm @@ -10,35 +10,158 @@ package Route::Node; use DXDebug; use Route; +use Route::User; use strict; -use vars qw(%list %valid @ISA $me); +use vars qw(%list %valid @ISA $max); @ISA = qw(Route); %valid = ( - dxchancall => '0,DXChannel Calls,parray', parent => '0,Parent Calls,parray', + nodes => '0,Nodes,parray', + users => '0,Users,parray', version => '0,Version', ); %list = (); +$max = 0; -sub init +sub count { - $me = Route::Node->new(@_); + my $n = scalar %list; + $max = $n if $n > $max; + return $n; +} + +sub max +{ + 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; + my $self = get($call); + if ($self) { + $self->_addparent($parent->{call}); + return undef; + } + $parent->_addnode($call); + $self = $parent->new($call, @_); + 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 + my $pcall = $pref->{call}; + my $ref = $self->_delparent($pcall); + my @nodes; + + # is this the last connection? + $self->_del_users; + unless (@$ref) { + push @nodes, $self->del_nodes; + delete $list{$self->{call}}; + } + push @nodes, $self; + return @nodes; +} + + +sub _del_users +{ + my $self = shift; + for (@{$self->{users}}) { + my $ref = Route::User::get($_); + $ref->del($self) if $ref; + } + $self->{users} = []; +} + +# remove all sub nodes from this parent +sub del_nodes +{ + my $self = shift; + my @nodes; + + for (@{$self->{nodes}}) { + next if $self->{call} eq $_; + push @nodes, $self->del_node($_); + } + return @nodes; +} + +# add a user to this node +sub add_user +{ + my $self = shift; + my $ucall = shift; + $self->_adduser($ucall); + + my $uref = Route::User::get($ucall); + return $uref ? () : (Route::User->new($ucall, $self->{call}, @_)); +} + +# delete a user from this node +sub del_user +{ + my $self = shift; + my $ucall = shift; + my $ref = Route::User::get($ucall); + $self->_deluser($ucall); + return ($ref->del($self)) if $ref; + return (); +} + +# delete a node from this node (ie I am a parent) +sub del_node +{ + my $self = shift; + my $ncall = shift; + $self->_delnode($ncall); + my $ref = get($ncall); + return ($ref->del($self)) if $ref; + return (); } 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->{dxchancall} = [ ]; - $self->{parent} = [ ]; + $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ]; $self->{version} = shift; + $self->{flags} = shift; + $self->{users} = []; + $self->{nodes} = []; $list{$call} = $self; @@ -52,28 +175,73 @@ sub get return $list{uc $call}; } -sub adddxchan +sub _addparent { my $self = shift; - $self->_addlist('dxchancall', @_); + return $self->_addlist('parent', @_); } -sub deldxchan +sub _delparent { my $self = shift; - $self->_dellist('dxchancall', @_); + return $self->_dellist('parent', @_); } -sub addparent + +sub _addnode { my $self = shift; - $self->_addlist('parent', @_); + return $self->_addlist('nodes', @_); } -sub delparent +sub _delnode { my $self = shift; - $self->_dellist('parent', @_); + return $self->_dellist('nodes', @_); +} + + +sub _adduser +{ + my $self = shift; + return $self->_addlist('users', @_); +} + +sub _deluser +{ + my $self = shift; + return $self->_dellist('users', @_); +} + +sub DESTROY +{ + my $self = shift; + my $pkg = ref $self; + my $call = $self->{call} || "Unknown"; + + dbg('route', "destroying $pkg with $call"); +} + +# +# generic AUTOLOAD for accessors +# + +sub AUTOLOAD +{ + no strict; + + my $self = shift; + $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 +# print "AUTOLOAD: $AUTOLOAD\n"; +# *{$AUTOLOAD} = sub {my $self = shift; @_ ? $self->{$name} = shift : $self->{$name}} ; + @_ ? $self->{$name} = shift : $self->{$name} ; } 1; diff --git a/perl/Route/User.pm b/perl/Route/User.pm index 274b26fe..4e3e59cf 100644 --- a/perl/Route/User.pm +++ b/perl/Route/User.pm @@ -13,28 +13,54 @@ use Route; use strict; -use vars qw(%list %valid @ISA); +use vars qw(%list %valid @ISA $max); @ISA = qw(Route); %valid = ( - node => '0,Node Calls,parray', + parent => '0,Parent Calls,parray', ); %list = (); +$max = 0; + +sub count +{ + my $n = scalar %list; + $max = $n if $n > $max; + return $n; +} + +sub max +{ + return $max; +} sub new { my $pkg = shift; my $call = uc shift; + my $ncall = uc shift; + my $flags = shift; confess "already have $call in $pkg" if $list{$call}; my $self = $pkg->SUPER::new($call); - $self->{node} = [ ]; + $self->{parent} = [ $ncall ]; + $self->{flags} = $flags; $list{$call} = $self; - + return $self; } +sub del +{ + my $self = shift; + my $pref = shift; + my $ref = $self->delparent($pref->{call}); + return () if @$ref; + delete $list{$self->{call}}; + return ($ref); +} + sub get { my $call = shift; @@ -42,16 +68,37 @@ sub get return $list{uc $call}; } -sub addnode +sub addparent +{ + my $self = shift; + return $self->_addlist('parent', @_); +} + +sub delparent { my $self = shift; - $self->_addlist('node', @_); + return $self->_dellist('parent', @_); } -sub delnode +# +# generic AUTOLOAD for accessors +# + +sub AUTOLOAD { + no strict; + my $self = shift; - $self->_dellist('node', @_); + $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 {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; + @_ ? $self->{$name} = shift : $self->{$name} ; } 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index 320ed037..fc0a6a04 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -98,7 +98,7 @@ package main; use strict; use vars qw(@inqueue $systime $version $starttime $lockfn @outstanding_connects $zombies $root @listeners $lang $myalias @debug $userfn $clusteraddr - $clusterport $mycall $decease $build $is_win + $clusterport $mycall $decease $build $is_win $routeroot ); @inqueue = (); # the main input queue, an array of hashes @@ -433,11 +433,11 @@ Spot->init(); # initialise the protocol engine dbg('err', "reading in duplicate spot and WWV info ..."); -Route::Node::init($mycall, $version); DXProt->init(); # put in a DXCluster node for us here so we can add users and take them away DXNode->new($DXProt::me, $mycall, 0, 1, $DXProt::myprot_version); +$routeroot = Route::Node->new($mycall, $version, Route::here($DXProt::me->here)|Route::conf($DXProt::me->confmode)); # read in any existing message headers and clean out old crap dbg('err', "reading existing message headers ...");