add more routing code together with associated commands

diff --git a/Changes b/Changes
index 815fe1fc4229749548357dcea9a4e4f44c9b0f97..b17e22fc29513344aae353b34a9e7b2395fa6c50 100644 (file)
--- 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.
 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 8765a69b62a6998a2dacecc47b2511fada1cd5f8..eaef20c9bb99fcd6ed413676efe3e1d1e65324b7 100644 (file)
--- 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
 
 === 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
 === 5^SET/CLX <call> [<call>..]^Make the callsign an CLX node
 
 === 9^SET/DEBUG <name>^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.
 
 
 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.
 
 === 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.
 === 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.

diff --git a/cmd/set/bbs.pl b/cmd/set/bbs.pl
new file mode 100644 (file)
index 0000000..0cb6cf3
--- /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 954a6655be63b96174f88941b481d11e1dea4b81..ba38b826767426a6fd47cc5c6143a1eb58b75106 100644 (file)
--- 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
 #
 #
 # 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 (file)
index 0000000..a2599b8
--- /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 910b1997d9fd94e662030cd75d3aac89e80f9915..6779db42cbe32375d04f255402bf13fba7ced39d 100644 (file)
--- 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) {
                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') {
                        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 5c5b46a04ed5bb4c9fd500a07311dcd96ce6da16..2b7ed7525c566c3635eb59134dd4c088af02ff46 100644 (file)
--- 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;
 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);
 }
 
 return (1, @out);

diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm
index 7602283fc367b0d8784f80e0ec8dc4ce56bcfa71..8a300d5f24dd3823827d0f080f68cc176e54f0c1 100644 (file)
--- 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',
                  cluster => '5,Cluster data',
                  isbasic => '9,Internal Connection', 
                  errors => '9,Errors',

+                 route => '9,Route Data',

                 );
 
 # object destruction
                 );
 
 # object destruction

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index 967cc022d10cbefb04fb0dcf68902c6ee5ffeeb3..0f80232ac8432636ef1d65a6f9a0bf609672e960 100644 (file)
--- 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
 
        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);
        # 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);
        }
 
                $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);
                
        # I was the last node visited
     $self->user->node($main::mycall);
                

diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm
index 790b398d1666d73c431f58d9560ae8ba50c1caee..766dacbd2a01187c35941cfc1e047d164ab1d799 100644 (file)
--- a/perl/DXDebug.pm
+++ b/perl/DXDebug.pm
@@ -11,14 +11,14 @@ package DXDebug;
 
 require Exporter;
 @ISA = qw(Exporter);
 
 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 strict;
 use vars qw(%dbglevel $fp);
 
 use DXUtil;
 use DXLog ();

-use Carp qw(cluck);
+use Carp ();

 
 %dbglevel = ();
 $fp = undef;
 
 %dbglevel = ();
 $fp = undef;


@@ -44,7 +44,8 @@ if (!defined $DB::VERSION) {
     CORE::die(Carp::shortmess($@)) if $@;
 } else {
     eval qq( sub confess { Carp::confess(\@_); }; 
     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 decd71f674452ea072172baab71a60b280d34f70..6fcf028924eb6007fd6befe6b8613f29b20c4646 100644 (file)
--- 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 Time::HiRes qw(gettimeofday tv_interval);
 use BadWords;
 use DXHash;

+use Route;

 use Route::Node;
 
 use strict;
 use Route::Node;
 
 use strict;


@@ -181,7 +182,7 @@ sub init
        confess $@ if $@;
        $me->{sort} = 'S';    # S for spider
        $me->{priv} = 9;
        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');
 
        # send info to all logged in thingies
        $self->tell_login('loginn');
 

+       $main::routeroot->add($call);

        Log('DXProt', "$call connected");
 }
 
        Log('DXProt', "$call connected");
 }
 


@@ -514,16 +516,9 @@ sub normal
                }
                
                if ($pcno == 16) {              # add a user
                }
                
                if ($pcno == 16) {              # add a user

-                       my $node = DXCluster->get_exact($field[1]); 
+
+                       # general checks

                        my $dxchan;
                        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;
                        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;
                        }
                                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;
                        }
                        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");
                        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");
                        }
                        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 $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);
                        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;
                                        }
                                                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';     
                        
                        # 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
                }
                
                if ($pcno == 17) {              # remove a user

-                       my $node = DXCluster->get_exact($field[2]);

                        my $dxchan;
                        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;
                        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;
                        }
                                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;
                        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;
                        }
                                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) {
                        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^";
                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);
                        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;
                                
                                # 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;
                                        }
                                                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;
                                }
                                        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^";
 
                                # 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;
                        }
                                $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^";
 
                        
                        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];
                
                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 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;
                                        }
                                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;
                                        }
                                        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");
                                        $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('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;
 #                      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")));
        }
 
                $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;
        # 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 ce256e1e047af374ebff015782412d02fdafe479..a5f6bc433b677fc3ac126e105fe56c578e97eb3c 100644 (file)
--- a/perl/DXProtVars.pm
+++ b/perl/DXProtVars.pm
@@ -11,12 +11,6 @@
 
 package DXProt;
 
 
 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;
 
 # the interval between pc50s (in seconds)
 $pc50_interval = 14*60;
 

diff --git a/perl/DXProtout.pm b/perl/DXProtout.pm
index 42c995510c2c265d6bf8aa52b0bbc91a4e5945a0..1ebb29bc8ceb7d356c7ac2d7309c2d4ad16d6a7b 100644 (file)
--- a/perl/DXProtout.pm
+++ b/perl/DXProtout.pm
@@ -80,7 +80,7 @@ sub pc16
 
        for ($i = 0; @_; ) {
                my $str = "PC16^$self->{call}";
 
        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;
                }
                        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 = 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';
                        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 0b3de9511e964f41c6834f025bcf4e60b1dc2f2d..b635e9816360f1dab46605eea7ed0b0d34c1c017 100644 (file)
--- 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 
 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
             );
              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);
 }
 
        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
 {
 # take an arg as an array list and print it
 sub parray
 {

diff --git a/perl/Messages b/perl/Messages
index cdeb2ee1e86af5cf39149b940dc8560a01f13251..a9a1be91d2e9e97c1d25921f82174874ddd60a71 100644 (file)
--- 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',
                                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',
                                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 2e90703e039b70015007fe8f4b0885f714e2c2e1..a9c521708bc1ddb4fbfdac36d3980a8e1aa84730 100644 (file)
--- a/perl/Route.pm
+++ b/perl/Route.pm
@@ -22,13 +22,16 @@ use vars qw(%list %valid);
 
 %valid = (
                  call => "0,Callsign",
 
 %valid = (
                  call => "0,Callsign",

+                 flags => "0,Flags,phex",

                 );
 
 sub new
 {
        my ($pkg, $call) = @_;
                 );
 
 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;
                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
 }
 
 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}} ];
                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;
        
        my $self = shift;
        my $pkg = ref $self;
        

-       dbg('route', "$pkg $self->{call} destroyed");
+       dbg('routelow', "$pkg $self->{call} destroyed");

 }
 
 no strict;
 }
 
 no strict;


@@ -95,7 +186,8 @@ no strict;
 sub fields
 {
        my $pkg = shift;
 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;
 }
        push @out, keys %valid;
        return @out;
 }


@@ -117,14 +209,15 @@ sub field_prompt
 sub AUTOLOAD
 {
        my $self = shift;
 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
 
        # 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} ;
 }
 
     @_ ? $self->{$name} = shift : $self->{$name} ;
 }
 

diff --git a/perl/Route/Node.pm b/perl/Route/Node.pm
index 2fee0acd40042365d5d494679c6b8cc6ac2aa435..9e1f3c04fecf7ba100ca35ed4c5594dc82578e91 100644 (file)
--- a/perl/Route/Node.pm
+++ b/perl/Route/Node.pm
@@ -10,35 +10,158 @@ package Route::Node;
 
 use DXDebug;
 use Route;
 
 use DXDebug;
 use Route;

+use Route::User;

 
 use strict;
 
 
 use strict;
 

-use vars qw(%list %valid @ISA $me);
+use vars qw(%list %valid @ISA $max);

 @ISA = qw(Route);
 
 %valid = (
 @ISA = qw(Route);
 
 %valid = (

-                 dxchancall => '0,DXChannel Calls,parray',

                  parent => '0,Parent Calls,parray',
                  parent => '0,Parent Calls,parray',

+                 nodes => '0,Nodes,parray',
+                 users => '0,Users,parray',

                  version => '0,Version',
 );
 
 %list = ();
                  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;
 }
 
 sub new
 {
        my $pkg = shift;
        my $call = uc shift;

+       

        confess "already have $call in $pkg" if $list{$call};
        
        my $self = $pkg->SUPER::new($call);
        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->{version} = shift;

+       $self->{flags} = shift;
+       $self->{users} = [];
+       $self->{nodes} = [];

        
        $list{$call} = $self;
        
        
        $list{$call} = $self;
        


@@ -52,28 +175,73 @@ sub get
        return $list{uc $call};
 }
 
        return $list{uc $call};
 }
 

-sub adddxchan
+sub _addparent

 {
        my $self = shift;
 {
        my $self = shift;

-    $self->_addlist('dxchancall', @_);
+    return $self->_addlist('parent', @_);

 }
 
 }
 

-sub deldxchan
+sub _delparent

 {
        my $self = shift;
 {
        my $self = shift;

-    $self->_dellist('dxchancall', @_);
+    return $self->_dellist('parent', @_);

 }
 
 }
 

-sub addparent
+
+sub _addnode

 {
        my $self = shift;
 {
        my $self = shift;

-    $self->_addlist('parent', @_);
+    return $self->_addlist('nodes', @_);

 }
 
 }
 

-sub delparent
+sub _delnode

 {
        my $self = shift;
 {
        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;
 }
 
 1;

diff --git a/perl/Route/User.pm b/perl/Route/User.pm
index 274b26fee0e45fde0ed1a82a7fec8e931964bb18..4e3e59cf7f7ccae64502c5a566653ba7750318a1 100644 (file)
--- a/perl/Route/User.pm
+++ b/perl/Route/User.pm
@@ -13,28 +13,54 @@ use Route;
 
 use strict;
 
 
 use strict;
 

-use vars qw(%list %valid @ISA);
+use vars qw(%list %valid @ISA $max);

 @ISA = qw(Route);
 
 %valid = (
 @ISA = qw(Route);
 
 %valid = (

-                 node => '0,Node Calls,parray',
+                 parent => '0,Parent Calls,parray',

 );
 
 %list = ();
 );
 
 %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;
 
 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);
        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;
        $list{$call} = $self;

-       
+

        return $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;
 sub get
 {
        my $call = shift;


@@ -42,16 +68,37 @@ sub get
        return $list{uc $call};
 }
 
        return $list{uc $call};
 }
 

-sub addnode
+sub addparent
+{
+       my $self = shift;
+    return $self->_addlist('parent', @_);
+}
+
+sub delparent

 {
        my $self = shift;
 {
        my $self = shift;

-    $self->_addlist('node', @_);
+    return $self->_dellist('parent', @_);

 }
 
 }
 

-sub delnode
+#
+# generic AUTOLOAD for accessors
+#
+
+sub AUTOLOAD

 {
 {

+       no strict;
+

        my $self = shift;
        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;
 }
 
 1;

diff --git a/perl/cluster.pl b/perl/cluster.pl
index 320ed037b6a3f822e5aab6ea8d2218a41fc2cd41..fc0a6a04a429c22cbee00fa6598847eb7489065e 100755 (executable)
--- 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 
 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
                   );
 
 @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 ...");
 
 # 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); 
 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 ...");
 
 # read in any existing message headers and clean out old crap
 dbg('err', "reading existing message headers ...");