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                   parent => '0,Parent Calls,parray',
  28                   nodes => '0,Nodes,parray',
  29                   users => '0,Users,parray',
  30                   usercount => '0,User Count',
  31                   version => '0,Version',
  32                   handle_xml => '0,Using XML,yesno',
  33                   lastmsg => '0,Last Route Msg,atime',
  34                   lastid => '0,Last Route MsgID',
  35                   do_pc92 => '0,Uses pc92,yesno',
  36 );
  37
  38 $filterdef = $Route::filterdef;
  39 %list = ();
  40 $max = 0;
  41
  42 sub count
  43 {
  44         my $n = scalar (keys %list);
  45         $max = $n if $n > $max;
  46         return $n;
  47 }
  48
  49 sub max
  50 {
  51         count();
  52         return $max;
  53 }
  54
  55 #
  56 # this routine handles the possible adding of an entry in the routing
  57 # table. It will only add an entry if it is new. It may have all sorts of
  58 # other side effects which may include fixing up other links.
  59 #
  60 # It will return a node object if (and only if) it is a completely new
  61 # object with that callsign. The upper layers are expected to do something
  62 # sensible with this!
  63 #
  64 # called as $parent->add(call, dxchan, version, flags)
  65 #
  66
  67 sub add
  68 {
  69         my $parent = shift;
  70         my $call = uc shift;
  71         confess "Route::add trying to add $call to myself" if $call eq $parent->{call};
  72         my $self = get($call);
  73         if ($self) {
  74                 $self->_addparent($parent);
  75                 $parent->_addnode($self);
  76                 return undef;
  77         }
  78         $self = $parent->new($call, @_);
  79         $parent->_addnode($self);
  80         return $self;
  81 }
  82
  83 #
  84 # this routine is the opposite of 'add' above.
  85 #
  86 # It will return an object if (and only if) this 'del' will remove
  87 # this object completely
  88 #
  89
  90 sub del
  91 {
  92         my $self = shift;
  93         my $pref = shift;
  94
  95         # delete parent from this call's parent list
  96         $pref->_delnode($self);
  97     $self->_delparent($pref);
  98         my @nodes;
  99         my $ncall = $self->{call};
 100
 101         # is this the last connection, I have no parents anymore?
 102         unless (@{$self->{parent}}) {
 103                 foreach my $rcall (@{$self->{nodes}}) {
 104                         next if grep $rcall eq $_, @_;
 105                         my $r = Route::Node::get($rcall);
 106                         push @nodes, $r->del($self, $ncall, @_) if $r;
 107                 }
 108                 $self->_del_users;
 109                 delete $list{$self->{call}};
 110                 push @nodes, $self;
 111         }
 112         return @nodes;
 113 }
 114
 115 sub del_nodes
 116 {
 117         my $parent = shift;
 118         my @out;
 119         foreach my $rcall (@{$parent->{nodes}}) {
 120                 my $r = get($rcall);
 121                 push @out, $r->del($parent, $parent->{call}, @_) if $r;
 122         }
 123         return @out;
 124 }
 125
 126 sub _del_users
 127 {
 128         my $self = shift;
 129         for (@{$self->{users}}) {
 130                 my $ref = Route::User::get($_);
 131                 $ref->del($self) if $ref;
 132         }
 133         $self->{users} = [];
 134 }
 135
 136 # add a user to this node
 137 sub add_user
 138 {
 139         my $self = shift;
 140         my $ucall = shift;
 141
 142         confess "Trying to add NULL User call to routing tables" unless $ucall;
 143
 144         my $uref = Route::User::get($ucall);
 145         my @out;
 146         if ($uref) {
 147                 @out = $uref->addparent($self);
 148         } else {
 149                 $uref = Route::User->new($ucall, $self->{call}, @_);
 150                 @out = $uref;
 151         }
 152         $self->_adduser($uref);
 153         $self->{usercount} = scalar @{$self->{users}};
 154
 155         return @out;
 156 }
 157
 158 # delete a user from this node
 159 sub del_user
 160 {
 161         my $self = shift;
 162         my $ref = shift;
 163         my @out;
 164
 165         if ($ref) {
 166                 @out = $self->_deluser($ref);
 167                 $ref->del($self);
 168         } else {
 169                 confess "tried to delete non-existant $ref->{call} from $self->{call}";
 170         }
 171         $self->{usercount} = scalar @{$self->{users}};
 172         return @out;
 173 }
 174
 175 sub usercount
 176 {
 177         my $self = shift;
 178         if (@_ && @{$self->{users}} == 0) {
 179                 $self->{usercount} = shift;
 180         }
 181         return $self->{usercount};
 182 }
 183
 184 sub users
 185 {
 186         my $self = shift;
 187         return @{$self->{users}};
 188 }
 189
 190 sub nodes
 191 {
 192         my $self = shift;
 193         return @{$self->{nodes}};
 194 }
 195
 196 sub parents
 197 {
 198         my $self = shift;
 199         return @{$self->{parent}};
 200 }
 201
 202 sub rnodes
 203 {
 204         my $self = shift;
 205         my @out;
 206         foreach my $call (@{$self->{nodes}}) {
 207                 next if grep $call eq $_, @_;
 208                 push @out, $call;
 209                 my $r = get($call);
 210                 push @out, $r->rnodes($call, @_) if $r;
 211         }
 212         return @out;
 213 }
 214
 215 # this takes in a list of node and user calls (not references) from
 216 # a config type update for a node and returns
 217 # the differences as lists of things that have gone away
 218 # and things that have been added.
 219 sub calc_config_changes
 220 {
 221         my $self = shift;
 222         my %nodes = map {$_ => 1} @{$self->{nodes}};
 223         my %users = map {$_ => 1} @{$self->{users}};
 224         my $cnodes = shift;
 225         my $cusers = shift;
 226         my (@dnodes, @dusers, @nnodes, @nusers);
 227         push @nnodes, map {my @r = $nodes{$_} ? () : $_; delete $nodes{$_}; @r} @$cnodes;
 228         push @dnodes, keys %nodes;
 229         push @nusers, map {my @r = $users{$_} ? () : $_; delete $users{$_}; @r} @$cusers;
 230         push @dusers, keys %users;
 231         return (\@dnodes, \@dusers, \@nnodes, \@nusers);
 232 }
 233
 234 sub new
 235 {
 236         my $pkg = shift;
 237         my $call = uc shift;
 238
 239         confess "already have $call in $pkg" if $list{$call};
 240
 241         my $self = $pkg->SUPER::new($call);
 242         $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ];
 243         $self->{version} = shift || 5000;
 244         $self->{flags} = shift || Route::here(1);
 245         $self->{users} = [];
 246         $self->{nodes} = [];
 247         $self->{lastid} = {};
 248
 249         $list{$call} = $self;
 250
 251         return $self;
 252 }
 253
 254 sub get
 255 {
 256         my $call = shift;
 257         $call = shift if ref $call;
 258         my $ref = $list{uc $call};
 259         dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr');
 260         return $ref;
 261 }
 262
 263 sub get_all
 264 {
 265         return values %list;
 266 }
 267
 268 sub _addparent
 269 {
 270         my $self = shift;
 271     return $self->_addlist('parent', @_);
 272 }
 273
 274 sub _delparent
 275 {
 276         my $self = shift;
 277     return $self->_dellist('parent', @_);
 278 }
 279
 280
 281 sub _addnode
 282 {
 283         my $self = shift;
 284     return $self->_addlist('nodes', @_);
 285 }
 286
 287 sub _delnode
 288 {
 289         my $self = shift;
 290     return $self->_dellist('nodes', @_);
 291 }
 292
 293
 294 sub _adduser
 295 {
 296         my $self = shift;
 297     return $self->_addlist('users', @_);
 298 }
 299
 300 sub _deluser
 301 {
 302         my $self = shift;
 303     return $self->_dellist('users', @_);
 304 }
 305
 306 sub DESTROY
 307 {
 308         my $self = shift;
 309         my $pkg = ref $self;
 310         my $call = $self->{call} || "Unknown";
 311
 312         dbg("destroying $pkg with $call") if isdbg('routelow');
 313 }
 314
 315 #
 316 # generic AUTOLOAD for accessors
 317 #
 318
 319 sub AUTOLOAD
 320 {
 321         no strict;
 322         my $name = $AUTOLOAD;
 323         return if $name =~ /::DESTROY$/;
 324         $name =~ s/^.*:://o;
 325
 326         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 327
 328         # this clever line of code creates a subroutine which takes over from autoload
 329         # from OO Perl - Conway
 330         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 331         goto &$AUTOLOAD;
 332 }
 333
 334 1;
 335