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                   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 remove_route
  85 {
  86         my ($self, $neighbour, $dxchan) = @_;
  87
  88         # cut the dxchan link
  89         # cut the node link
  90         my @rout;
  91         push @rout, $self->unlink_node($neighbour, $dxchan);
  92         dbg("Orphanning $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                 my ($o) = $r->del_dxchan($dxchan);
 102                 if ($o) {
 103                         dbg("Orphanning $o->{call}") if isdbg('routelow');
 104                         push @rout, $o;
 105                 }
 106                 push @in, map{ Route::Node::get($_) } $r->nodes;
 107                 $visited{$r->call} = $r;
 108         }
 109
 110         # in @rout there should be a list of orphaned (in dxchan terms)
 111         # nodes. Now go thru and make sure that all their links are
 112         # broken (they should be, but this is to check).
 113
 114         foreach my $r (@rout) {
 115                 my @nodes = map { Route::Node::get($_)} $r->nodes;
 116                 for (@nodes) {
 117                         next unless $_;
 118                         dbg("Orphaned node $_->{call}: breaking link to $_->{call}") if isdbg('routelow');
 119                         $r->unlink_node($_);
 120                 }
 121         }
 122         return @rout;
 123 }
 124
 125 # add a user to this node
 126 # returns Route::User if it is a new user;
 127 sub add_user
 128 {
 129         my ($self, $uref) = @_;
 130         my $r = $uref->is_empty('nodes');
 131         $self->_addlist('users', $uref);
 132         $uref->_addlist('nodes', $self);
 133         $self->{usercount} = scalar @{$self->{users}};
 134         return $r ? ($uref) : ();
 135 }
 136
 137 # delete a user from this node
 138 sub del_user
 139 {
 140         my ($self, $uref) = @_;
 141
 142         $self->_dellist('users', $uref);
 143         $uref->_dellist('nodes', $self);
 144         $self->{usercount} = scalar @{$self->{users}};
 145         return $uref->is_empty('nodes') ? ($uref) : ();
 146 }
 147
 148 # add a single dxchan link
 149 sub add_dxchan
 150 {
 151         my ($self, $dxchan) = @_;
 152         return $self->_addlist('dxchan', $dxchan);
 153 }
 154
 155 # remove a single dxchan link
 156 sub del_dxchan
 157 {
 158         my ($self, $dxchan) = @_;
 159         $self->_dellist('dxchan', $dxchan);
 160         return $self->is_empty('dxchan') ? ($self) : ();
 161 }
 162
 163 sub usercount
 164 {
 165         my $self = shift;
 166         if (@_ && @{$self->{users}} == 0) {
 167                 $self->{usercount} = shift;
 168         }
 169         return $self->{usercount};
 170 }
 171
 172 sub users
 173 {
 174         my $self = shift;
 175         return @{$self->{users}};
 176 }
 177
 178 sub nodes
 179 {
 180         my $self = shift;
 181         return @{$self->{nodes}};
 182 }
 183
 184 sub unlink_all_users
 185 {
 186         my $self = shift;
 187         my @rout;
 188         foreach my $u (@{$self->{users}}) {
 189                 my $uref = Route::User::get($u);
 190                 push @rout, $self->del_user($uref) if $uref;
 191         }
 192         return @rout;
 193 }
 194
 195 sub new
 196 {
 197         my $pkg = shift;
 198         my $call = uc shift;
 199
 200         confess "already have $call in $pkg" if $list{$call};
 201
 202         my $self = $pkg->SUPER::new($call);
 203         $self->{dxchan} = [ ];
 204         $self->{version} = shift || 5000;
 205         $self->{flags} = shift || Route::here(1);
 206         $self->{users} = [];
 207         $self->{nodes} = [];
 208
 209         $list{$call} = $self;
 210         dbg("creating Route::Node $self->{call}") if isdbg('routelow');
 211
 212         return $self;
 213 }
 214
 215 sub delete
 216 {
 217         my $self = shift;
 218         dbg("Deleting Route::Node $self->{call}") if isdbg('routelow');
 219         for ($self->unlink_all_users) {
 220                 $_->delete;
 221         }
 222         delete $list{$self->{call}};
 223 }
 224
 225 sub get
 226 {
 227         my $call = shift;
 228         $call = shift if ref $call;
 229         my $ref = $list{uc $call};
 230         dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr');
 231         return $ref;
 232 }
 233
 234 sub get_all
 235 {
 236         return values %list;
 237 }
 238
 239 sub DESTROY
 240 {
 241         my $self = shift;
 242         my $pkg = ref $self;
 243         my $call = $self->{call} || "Unknown";
 244
 245         dbg("destroying $pkg with $call") if isdbg('routelow');
 246         $self->unlink_all_users if @{$self->{users}};
 247 }
 248
 249 #
 250 # generic AUTOLOAD for accessors
 251 #
 252
 253 sub AUTOLOAD
 254 {
 255         no strict;
 256         my $name = $AUTOLOAD;
 257         return if $name =~ /::DESTROY$/;
 258         $name =~ s/^.*:://o;
 259
 260         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 261
 262         # this clever line of code creates a subroutine which takes over from autoload
 263         # from OO Perl - Conway
 264         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 265         goto &$AUTOLOAD;
 266 }
 267
 268 1;
 269