+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.
=== 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 <call> [<call>..]^Make the callsign a BBS
+
=== 5^SET/CLX <call> [<call>..]^Make the callsign an CLX node
=== 9^SET/DEBUG <name>^Add a debug level to the debug set
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 <msgno>^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 <callsign>^Show the data in a Route::Node object
+
+=== 5^STAT/ROUTE_USER <callsign>^Show the data in a Route::User object
+
=== 5^STAT/USER [<callsign>]^Show the full status of a user
Shows the full contents of a user record including all the secret flags
and stuff.
--- /dev/null
+#
+# 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);
#
-# 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
#
--- /dev/null
+#
+# 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);
+
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') {
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);
cluster => '5,Cluster data',
isbasic => '9,Internal Connection',
errors => '9,Errors',
+ route => '9,Route Data',
);
# object destruction
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);
$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);
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;
CORE::die(Carp::shortmess($@)) if $@;
} else {
eval qq( sub confess { Carp::confess(\@_); };
- sub cluck { Carp::cluck(\@_); };
+ sub croak { Carp::croak(\@_); };
+ sub cluck { Carp::cluck(\@_); };
);
}
use Time::HiRes qw(gettimeofday tv_interval);
use BadWords;
use DXHash;
+use Route;
use Route::Node;
use strict;
confess $@ if $@;
$me->{sort} = 'S'; # S for spider
$me->{priv} = 9;
- $Route::Node::me->adddxchan($me);
+# $Route::Node::me->adddxchan($me);
}
#
# send info to all logged in thingies
$self->tell_login('loginn');
+ $main::routeroot->add($call);
Log('DXProt', "$call connected");
}
}
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;
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';
}
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;
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;
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) {
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^";
$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^";
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");
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;
$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;
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;
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;
}
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';
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
);
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
{
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',
%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);
}
#
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
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;
}
#
my $self = shift;
my $pkg = ref $self;
- dbg('route', "$pkg $self->{call} destroyed");
+ dbg('routelow', "$pkg $self->{call} destroyed");
}
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;
}
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} ;
}
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;
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;
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;
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;
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
# 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 ...");
projects / spider.git / commitdiff