perl/Route/Node.pm

   1 #
   2 # Node routing routines
   3 #
   4 # Copyright (c) 2001 Dirk Koopman G1TLH
   5 #
   6 # $Id$
   7 #
   8
   9 package Route::Node;
  10
  11 use DXDebug;
  12 use Route;
  13 use Route::User;
  14
  15 use strict;
  16
  17 use vars qw($VERSION $BRANCH);
  18 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /:\s+(\d+)\.(\d+)/ );
  19 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /:\s+\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  20 $main::build += $VERSION;
  21 $main::branch += $BRANCH;
  22
  23 use vars qw(%list %valid @ISA $max $filterdef);
  24 @ISA = qw(Route);
  25
  26 %valid = (
  27                   dxchan => '0,DXChannel List,parray',
  28                   nodes => '0,Node List,parray',
  29                   users => '0,User List,parray',
  30                   usercount => '0,User Count',
  31                   version => '0,Version',
  32                   newroute => '0,New Routing?,yesno',
  33                   pingtime => '0,Ping Time',
  34 );
  35
  36 $filterdef = $Route::filterdef;
  37 %list = ();
  38 $max = 0;
  39
  40 sub count
  41 {
  42         my $n = scalar (keys %list);
  43         $max = $n if $n > $max;
  44         return $n;
  45 }
  46
  47 sub max
  48 {
  49         count();
  50         return $max;
  51 }
  52
  53 # link a node to this node and mark the route as available thru
  54 # this dxchan, any users must be linked separately
  55 #
  56 # call as $node->link_node($neighbour, $dxchan);
  57 #
  58
  59 sub link_node
  60 {
  61         my ($self, $neighbour, $dxchan) = @_;
  62
  63         my $r = $neighbour->is_empty('dxchan');
  64         $self->_addlist('nodes', $neighbour);
  65         $neighbour->_addlist('nodes', $self);
  66         $neighbour->_addlist('dxchan', $dxchan);
  67         return $r ? ($neighbour) : ();
  68 }
  69
  70 # unlink a node from a neighbour and remove any
  71 # routes, if this node becomes orphaned (no routes
  72 # and no nodes) then return it
  73 #
  74
  75 sub unlink_node
  76 {
  77         my ($self, $neighbour, $dxchan) = @_;
  78         $self->_dellist('nodes', $neighbour);
  79         $neighbour->_dellist('nodes', $self);
  80         $neighbour->_dellist('dxchan', $dxchan) if $dxchan;
  81         return $neighbour->is_empty('dxchan') ? ($neighbour) : ();
  82 }
  83
  84 sub add_route
  85 {
  86         my ($self, $neighbour, $dxchan) = @_;
  87
  88         # add the dxchan link
  89         # add the node link
  90         my @rout;
  91         push @rout, $self->link_node($neighbour, $dxchan);
  92         dbg("Adding $neighbour->{call}") if isdbg('routelow');
  93
  94         # then run down the tree removing this dxchan link from
  95         # all the referenced nodes that use this interface
  96         my %visited;
  97         my @in = map { Route::Node::get($_) } $neighbour->nodes;
  98         foreach my $r (@in) {
  99                 next unless $r;
 100                 next if $visited{$r->call};
 101                 next if $r->{call} eq $main::mycall;
 102                 next if $r->{call} eq $self->{call};
 103                 my ($o) = $r->add_dxchan($dxchan);
 104                 if ($o) {
 105                         dbg("Connecting new node $o->{call}") if isdbg('routelow');
 106                         push @rout, $o;
 107                 }
 108                 push @in, map{ Route::Node::get($_) } $r->nodes;
 109                 $visited{$r->call} = $r;
 110         }
 111
 112         # @rout should contain any nodes that have now been de-orphaned
 113         # ie have had their first dxchan added.
 114         return @rout;
 115 }
 116
 117 sub remove_route
 118 {
 119         my ($self, $neighbour, $dxchan) = @_;
 120
 121         # cut the dxchan link
 122         # cut the node link
 123         my @rout;
 124         push @rout, $self->unlink_node($neighbour, $dxchan);
 125         dbg("Orphanning $neighbour->{call}") if isdbg('routelow');
 126
 127         # then run down the tree removing this dxchan link from
 128         # all the referenced nodes that use this interface
 129         my %visited;
 130         my @in = map { Route::Node::get($_) } $neighbour->nodes;
 131         foreach my $r (@in) {
 132                 next unless $r;
 133                 next if $visited{$r->call};
 134                 next if $r->{call} eq $main::mycall;
 135                 next if $r->{call} eq $self->{call};
 136                 my ($o) = $r->del_dxchan($dxchan);
 137                 if ($o) {
 138                         dbg("Orphanning $o->{call}") if isdbg('routelow');
 139                         push @rout, $o;
 140                 }
 141                 push @in, map{ Route::Node::get($_) } $r->nodes;
 142                 $visited{$r->call} = $r;
 143         }
 144
 145         # in @rout there should be a list of orphaned (in dxchan terms)
 146         # nodes. Now go thru and make sure that all their links are
 147         # broken (they should be, but this is to check).
 148
 149         foreach my $r (@rout) {
 150                 my @nodes = map { Route::Node::get($_)} $r->nodes;
 151                 for (@nodes) {
 152                         next unless $_;
 153                         dbg("Orphaned node $_->{call}: breaking link to $_->{call}") if isdbg('routelow');
 154                         $r->unlink_node($_);
 155                 }
 156         }
 157         return @rout;
 158 }
 159
 160 # add a user to this node
 161 # returns Route::User if it is a new user;
 162 sub add_user
 163 {
 164         my ($self, $uref) = @_;
 165         my $r = $uref->is_empty('nodes');
 166         $self->_addlist('users', $uref);
 167         $uref->_addlist('nodes', $self);
 168         $self->{usercount} = scalar @{$self->{users}};
 169         return $r ? ($uref) : ();
 170 }
 171
 172 # delete a user from this node
 173 sub del_user
 174 {
 175         my ($self, $uref) = @_;
 176
 177         $self->_dellist('users', $uref);
 178         $uref->_dellist('nodes', $self);
 179         $self->{usercount} = scalar @{$self->{users}};
 180         return $uref->is_empty('nodes') ? ($uref) : ();
 181 }
 182
 183 # add a single dxchan link
 184 sub add_dxchan
 185 {
 186         my ($self, $dxchan) = @_;
 187         return $self->_addlist('dxchan', $dxchan);
 188 }
 189
 190 # remove a single dxchan link
 191 sub del_dxchan
 192 {
 193         my ($self, $dxchan) = @_;
 194         $self->_dellist('dxchan', $dxchan);
 195         return $self->is_empty('dxchan') ? ($self) : ();
 196 }
 197
 198 sub usercount
 199 {
 200         my $self = shift;
 201         if (@_ && @{$self->{users}} == 0) {
 202                 $self->{usercount} = shift;
 203         }
 204         return $self->{usercount};
 205 }
 206
 207 sub users
 208 {
 209         my $self = shift;
 210         return @{$self->{users}};
 211 }
 212
 213 sub nodes
 214 {
 215         my $self = shift;
 216         return @{$self->{nodes}};
 217 }
 218
 219 sub unlink_all_users
 220 {
 221         my $self = shift;
 222         my @rout;
 223         foreach my $u (@{$self->{users}}) {
 224                 my $uref = Route::User::get($u);
 225                 push @rout, $self->del_user($uref) if $uref;
 226         }
 227         return @rout;
 228 }
 229
 230 sub new
 231 {
 232         my $pkg = shift;
 233         my $call = uc shift;
 234
 235         confess "already have $call in $pkg" if $list{$call};
 236
 237         my $self = $pkg->SUPER::new($call);
 238         $self->{dxchan} = [ ];
 239         $self->{version} = shift || 5000;
 240         $self->{flags} = shift || Route::here(1);
 241         $self->{users} = [];
 242         $self->{nodes} = [];
 243
 244         $list{$call} = $self;
 245
 246         return $self;
 247 }
 248
 249 sub delete
 250 {
 251         my $self = shift;
 252         dbg("Deleting Route::Node $self->{call}") if isdbg('routelow');
 253         for ($self->unlink_all_users) {
 254                 $_->delete;
 255         }
 256         delete $list{$self->{call}};
 257 }
 258
 259 sub get
 260 {
 261         my $call = shift;
 262         $call = shift if ref $call;
 263         my $ref = $list{uc $call};
 264         dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr');
 265         return $ref;
 266 }
 267
 268 sub get_all
 269 {
 270         return values %list;
 271 }
 272
 273 sub DESTROY
 274 {
 275         my $self = shift;
 276         my $pkg = ref $self;
 277         my $call = $self->{call} || "Unknown";
 278
 279         dbg("destroying $pkg with $call") if isdbg('routelow');
 280         $self->unlink_all_users if @{$self->{users}};
 281 }
 282
 283 #
 284 # generic AUTOLOAD for accessors
 285 #
 286
 287 sub AUTOLOAD
 288 {
 289         no strict;
 290         my $name = $AUTOLOAD;
 291         return if $name =~ /::DESTROY$/;
 292         $name =~ s/^.*:://o;
 293
 294         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 295
 296         # this clever line of code creates a subroutine which takes over from autoload
 297         # from OO Perl - Conway
 298         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 299         goto &$AUTOLOAD;
 300 }
 301
 302 1;
 303