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,Nodes,parray',
  29                   users => '0,Users,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($self);
 101                 if ($o) {
 102                         dbg("Orphanning $_->{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         return $self->_dellist('dxchan', $dxchan);
 159 }
 160
 161 sub usercount
 162 {
 163         my $self = shift;
 164         if (@_ && @{$self->{users}} == 0) {
 165                 $self->{usercount} = shift;
 166         }
 167         return $self->{usercount};
 168 }
 169
 170 sub users
 171 {
 172         my $self = shift;
 173         return @{$self->{users}};
 174 }
 175
 176 sub nodes
 177 {
 178         my $self = shift;
 179         return @{$self->{nodes}};
 180 }
 181
 182 sub unlink_all_users
 183 {
 184         my $self = shift;
 185         my @rout;
 186         foreach my $u (${$self->{users}}) {
 187                 my $uref = Route::User::get($u);
 188                 push @rout, $self->del_user($uref) if $uref;
 189         }
 190         return @rout;
 191 }
 192
 193 sub new
 194 {
 195         my $pkg = shift;
 196         my $call = uc shift;
 197
 198         confess "already have $call in $pkg" if $list{$call};
 199
 200         my $self = $pkg->SUPER::new($call);
 201         $self->{dxchan} = ref $pkg ? [ $pkg->{call} ] : [ ];
 202         $self->{version} = shift || 5000;
 203         $self->{flags} = shift || Route::here(1);
 204         $self->{users} = [];
 205         $self->{nodes} = [];
 206
 207         $list{$call} = $self;
 208         dbg("creating Route::Node $self->{call}") if isdbg('routelow');
 209
 210         return $self;
 211 }
 212
 213 sub delete
 214 {
 215         my $self = shift;
 216         dbg("deleting Route::Node $self->{call}") if isdbg('routelow');
 217         delete $list{$self->{call}};
 218 }
 219
 220 sub get
 221 {
 222         my $call = shift;
 223         $call = shift if ref $call;
 224         my $ref = $list{uc $call};
 225         dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr');
 226         return $ref;
 227 }
 228
 229 sub get_all
 230 {
 231         return values %list;
 232 }
 233
 234 sub DESTROY
 235 {
 236         my $self = shift;
 237         my $pkg = ref $self;
 238         my $call = $self->{call} || "Unknown";
 239
 240         dbg("destroying $pkg with $call") if isdbg('routelow');
 241         $self->unlink_all_users if @{$self->{users}};
 242 }
 243
 244 #
 245 # generic AUTOLOAD for accessors
 246 #
 247
 248 sub AUTOLOAD
 249 {
 250         no strict;
 251         my $name = $AUTOLOAD;
 252         return if $name =~ /::DESTROY$/;
 253         $name =~ s/^.*:://o;
 254
 255         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 256
 257         # this clever line of code creates a subroutine which takes over from autoload
 258         # from OO Perl - Conway
 259         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 260         goto &$AUTOLOAD;
 261 }
 262
 263 1;
 264