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$ =~ /(\d+)\.(\d+)/ );
  19 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\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 );
  34
  35 $filterdef = $Route::filterdef;
  36 %list = ();
  37 $max = 0;
  38
  39 sub count
  40 {
  41         my $n = scalar (keys %list);
  42         $max = $n if $n > $max;
  43         return $n;
  44 }
  45
  46 sub max
  47 {
  48         count();
  49         return $max;
  50 }
  51
  52 # link a node to this node and mark the route as available thru
  53 # this dxchan, any users must be linked separately
  54 #
  55 # call as $node->link_node($neighbour, $dxchan);
  56 #
  57
  58 sub link_node
  59 {
  60         my ($self, $neighbour, $dxchan) = @_;
  61
  62         my $r = $neighbour->is_empty('dxchan');
  63         $self->_addlist('nodes', $neighbour);
  64         $neighbour->_addlist('nodes', $self);
  65         $neighbour->_addlist('dxchan', $dxchan);
  66         return $r ? ($neighbour) : ();
  67 }
  68
  69 # unlink a node from a neighbour and remove any
  70 # routes, if this node becomes orphaned (no routes
  71 # and no nodes) then return it
  72 #
  73
  74 sub unlink_node
  75 {
  76         my ($self, $neighbour, $dxchan) = @_;
  77         $self->_dellist('nodes', $neighbour);
  78         $neighbour->_dellist('nodes', $self);
  79         $neighbour->_dellist('dxchan', $dxchan) if $dxchan;
  80         return $neighbour->is_empty('dxchan') ? ($neighbour) : ();
  81 }
  82
  83 sub remove_route
  84 {
  85         my ($self, $neighbour, $dxchan) = @_;
  86
  87         # cut the dxchan link
  88         # cut the node link
  89         my @rout;
  90         push @rout, $self->unlink_node($neighbour, $dxchan);
  91         dbg("Orphanning $neighbour->{call}") if isdbg('routelow');
  92
  93         # then run down the tree removing this dxchan link from
  94         # all the referenced nodes that use this interface
  95         my %visited;
  96         my @in = map { Route::Node::get($_) } $neighbour->nodes;
  97         foreach my $r (@in) {
  98                 next unless $r;
  99                 next if $visited{$r->call};
 100                 my ($o) = $r->del_dxchan($dxchan);
 101                 if ($o) {
 102                         dbg("Orphanning $o->{call}") if isdbg('routelow');
 103                         push @rout, $o;
 104                 }
 105                 push @in, map{ Route::Node::get($_) } $r->nodes;
 106                 $visited{$r->call} = $r;
 107         }
 108
 109         # in @rout there should be a list of orphaned (in dxchan terms)
 110         # nodes. Now go thru and make sure that all their links are
 111         # broken (they should be, but this is to check).
 112
 113         foreach my $r (@rout) {
 114                 my @nodes = map { Route::Node::get($_)} $r->nodes;
 115                 for (@nodes) {
 116                         next unless $_;
 117                         dbg("Orphaned node $_->{call}: breaking link to $_->{call}") if isdbg('routelow');
 118                         $r->unlink_node($_);
 119                 }
 120         }
 121         return @rout;
 122 }
 123
 124 # add a user to this node
 125 # returns Route::User if it is a new user;
 126 sub add_user
 127 {
 128         my ($self, $uref) = @_;
 129         my $r = $uref->is_empty('nodes');
 130         $self->_addlist('users', $uref);
 131         $uref->_addlist('nodes', $self);
 132         $self->{usercount} = scalar @{$self->{users}};
 133         return $r ? ($uref) : ();
 134 }
 135
 136 # delete a user from this node
 137 sub del_user
 138 {
 139         my ($self, $uref) = @_;
 140
 141         $self->_dellist('users', $uref);
 142         $uref->_dellist('nodes', $self);
 143         $self->{usercount} = scalar @{$self->{users}};
 144         return $uref->is_empty('nodes') ? ($uref) : ();
 145 }
 146
 147 # add a single dxchan link
 148 sub add_dxchan
 149 {
 150         my ($self, $dxchan) = @_;
 151         return $self->_addlist('dxchan', $dxchan);
 152 }
 153
 154 # remove a single dxchan link
 155 sub del_dxchan
 156 {
 157         my ($self, $dxchan) = @_;
 158         $self->_dellist('dxchan', $dxchan);
 159         return $self->is_empty('dxchan') ? ($self) : ();
 160 }
 161
 162 sub usercount
 163 {
 164         my $self = shift;
 165         if (@_ && @{$self->{users}} == 0) {
 166                 $self->{usercount} = shift;
 167         }
 168         return $self->{usercount};
 169 }
 170
 171 sub users
 172 {
 173         my $self = shift;
 174         return @{$self->{users}};
 175 }
 176
 177 sub nodes
 178 {
 179         my $self = shift;
 180         return @{$self->{nodes}};
 181 }
 182
 183 sub unlink_all_users
 184 {
 185         my $self = shift;
 186         my @rout;
 187         foreach my $u (@{$self->{users}}) {
 188                 my $uref = Route::User::get($u);
 189                 push @rout, $self->del_user($uref) if $uref;
 190         }
 191         return @rout;
 192 }
 193
 194 sub new
 195 {
 196         my $pkg = shift;
 197         my $call = uc shift;
 198
 199         confess "already have $call in $pkg" if $list{$call};
 200
 201         my $self = $pkg->SUPER::new($call);
 202         $self->{dxchan} = [ ];
 203         $self->{version} = shift || 5000;
 204         $self->{flags} = shift || Route::here(1);
 205         $self->{users} = [];
 206         $self->{nodes} = [];
 207
 208         $list{$call} = $self;
 209         dbg("creating Route::Node $self->{call}") if isdbg('routelow');
 210
 211         return $self;
 212 }
 213
 214 sub delete
 215 {
 216         my $self = shift;
 217         dbg("Deleting Route::Node $self->{call}") if isdbg('routelow');
 218         for ($self->unlink_all_users) {
 219                 $_->delete;
 220         }
 221         delete $list{$self->{call}};
 222 }
 223
 224 sub get
 225 {
 226         my $call = shift;
 227         $call = shift if ref $call;
 228         my $ref = $list{uc $call};
 229         dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr');
 230         return $ref;
 231 }
 232
 233 sub get_all
 234 {
 235         return values %list;
 236 }
 237
 238 sub DESTROY
 239 {
 240         my $self = shift;
 241         my $pkg = ref $self;
 242         my $call = $self->{call} || "Unknown";
 243
 244         dbg("destroying $pkg with $call") if isdbg('routelow');
 245         $self->unlink_all_users if @{$self->{users}};
 246 }
 247
 248 #
 249 # generic AUTOLOAD for accessors
 250 #
 251
 252 sub AUTOLOAD
 253 {
 254         no strict;
 255         my $name = $AUTOLOAD;
 256         return if $name =~ /::DESTROY$/;
 257         $name =~ s/^.*:://o;
 258
 259         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 260
 261         # this clever line of code creates a subroutine which takes over from autoload
 262         # from OO Perl - Conway
 263         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 264         goto &$AUTOLOAD;
 265 }
 266
 267 1;
 268