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 );
  33
  34 $filterdef = $Route::filterdef;
  35 %list = ();
  36 $max = 0;
  37
  38 sub count
  39 {
  40         my $n = scalar (keys %list);
  41         $max = $n if $n > $max;
  42         return $n;
  43 }
  44
  45 sub max
  46 {
  47         count();
  48         return $max;
  49 }
  50
  51 # link a node to this node and mark the route as available thru
  52 # this dxchan, any users must be linked separately
  53 #
  54 # call as $node->link_node($neighbour, $dxchan);
  55 #
  56
  57 sub link_node
  58 {
  59         my ($self, $neighbour, $dxchan) = @_;
  60
  61         my $r = $self->is_empty('dxchan');
  62         $self->_addlist('nodes', $neighbour);
  63         $neighbour->_addlist('nodes', $self);
  64         $self->_addlist('dxchan', $dxchan);
  65         $neighbour->_addlist('dxchan', $dxchan);
  66         return $r ? ($self) : ();
  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         $self->_dellist('dxchan', $dxchan);
  80         $neighbour->_dellist('dxchan', $dxchan);
  81         return $self->is_empty('dxchan') ? ($self) : ();
  82 }
  83
  84 # add a user to this node
  85 # returns Route::User if it is a new user;
  86 sub add_user
  87 {
  88         my ($self, $uref) = @_;
  89         my $r = $uref->is_empty('nodes');
  90         $self->_addlist('users', $uref);
  91         $uref->_addlist('nodes', $self);
  92         $self->{usercount} = scalar @{$self->{users}};
  93         return $r ? ($uref) : ();
  94 }
  95
  96 # delete a user from this node
  97 sub del_user
  98 {
  99         my ($self, $uref) = @_;
 100
 101         $self->_dellist('users', $uref);
 102         $uref->_dellist('nodes', $self);
 103         $self->{usercount} = scalar @{$self->{users}};
 104         return $uref->is_empty('nodes') ? ($uref) : ();
 105 }
 106
 107 sub usercount
 108 {
 109         my $self = shift;
 110         if (@_ && @{$self->{users}} == 0) {
 111                 $self->{usercount} = shift;
 112         }
 113         return $self->{usercount};
 114 }
 115
 116 sub users
 117 {
 118         my $self = shift;
 119         return @{$self->{users}};
 120 }
 121
 122 sub nodes
 123 {
 124         my $self = shift;
 125         return @{$self->{nodes}};
 126 }
 127
 128 sub unlink_all_users
 129 {
 130         my $self = shift;
 131         foreach my $u (${$self->{nodes}}) {
 132                 my $uref = Route::User::get($u);
 133                 $self->unlink_user($uref) if $uref;
 134         }
 135 }
 136
 137 sub new
 138 {
 139         my $pkg = shift;
 140         my $call = uc shift;
 141
 142         confess "already have $call in $pkg" if $list{$call};
 143
 144         my $self = $pkg->SUPER::new($call);
 145         $self->{dxchan} = ref $pkg ? [ $pkg->{call} ] : [ ];
 146         $self->{version} = shift;
 147         $self->{flags} = shift;
 148         $self->{users} = [];
 149         $self->{nodes} = [];
 150         $self->{lid} = 0;
 151
 152         $list{$call} = $self;
 153         dbg("creating Route::Node $self->{call}") if isdbg('routelow');
 154
 155         return $self;
 156 }
 157
 158 sub delete
 159 {
 160         my $self = shift;
 161         dbg("deleting Route::Node $self->{call}") if isdbg('routelow');
 162         delete $list{$self->{call}};
 163 }
 164
 165 sub get
 166 {
 167         my $call = shift;
 168         $call = shift if ref $call;
 169         my $ref = $list{uc $call};
 170         dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr');
 171         return $ref;
 172 }
 173
 174 sub get_all
 175 {
 176         return values %list;
 177 }
 178
 179 sub DESTROY
 180 {
 181         my $self = shift;
 182         my $pkg = ref $self;
 183         my $call = $self->{call} || "Unknown";
 184
 185         dbg("destroying $pkg with $call") if isdbg('routelow');
 186         $self->unlink_all_users if @{$self->{users}};
 187 }
 188
 189 #
 190 # generic AUTOLOAD for accessors
 191 #
 192
 193 sub AUTOLOAD
 194 {
 195         no strict;
 196         my $name = $AUTOLOAD;
 197         return if $name =~ /::DESTROY$/;
 198         $name =~ s/^.*:://o;
 199
 200         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 201
 202         # this clever line of code creates a subroutine which takes over from autoload
 203         # from OO Perl - Conway
 204         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 205         goto &$AUTOLOAD;
 206 }
 207
 208 1;
 209