perl/Route/Node.pm

   1 #
   2 # Node routing routines
   3 #
   4 # Copyright (c) 2001 Dirk Koopman G1TLH
   5 #
   6 #
   7 #
   8
   9 package Route::Node;
  10
  11 use DXDebug;
  12 use Route;
  13 use Route::User;
  14 use DXUtil;
  15
  16 use strict;
  17
  18 use vars qw(%list %valid @ISA $max $filterdef $obscount);
  19 @ISA = qw(Route);
  20
  21 %valid = (
  22                   nodes => '0,Nodes,parray',
  23                   users => '0,Users,parray',
  24                   usercount => '0,User Count',
  25                   version => '0,Version',
  26                   build => '0,Build',
  27                   handle_xml => '0,Using XML,yesno',
  28                   lastmsg => '0,Last Route Msg,atime',
  29                   lastid => '0,Last Route MsgID',
  30                   do_pc9x => '0,Uses pc9x,yesno',
  31                   via_pc92 => '0,In via pc92?,yesno',
  32                   obscount => '0,Obscount',
  33                   last_PC92C => '9,Last PC92C',
  34                   PC92C_dxchan => '9,PC92C hops,phash',
  35 );
  36
  37 $filterdef = $Route::filterdef;
  38 %list = ();
  39 $max = 0;
  40 $obscount = 3;
  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         dbg("CLUSTER: node $call added") if isdbg('cluster');
  81         return $self;
  82 }
  83
  84 #
  85 # this routine is the opposite of 'add' above.
  86 #
  87 # It will return an object if (and only if) this 'del' will remove
  88 # this object completely
  89 #
  90
  91 sub del
  92 {
  93         my $self = shift;
  94         my $pref = shift;
  95
  96         # delete parent from this call's parent list
  97         $pref->_delnode($self);
  98     $self->_delparent($pref);
  99         my @nodes;
 100         my $ncall = $self->{call};
 101
 102         # is this the last connection, I have no parents anymore?
 103         unless (@{$self->{parent}}) {
 104                 foreach my $rcall (@{$self->{nodes}}) {
 105                         next if grep $rcall eq $_, @_;
 106                         my $r = Route::Node::get($rcall);
 107                         push @nodes, $r->del($self, $ncall, @_) if $r;
 108                 }
 109                 $self->_del_users;
 110                 delete $list{$ncall};
 111                 push @nodes, $self;
 112                 dbg("CLUSTER: node $ncall deleted") if isdbg('cluster');
 113         }
 114         return @nodes;
 115 }
 116
 117 # this deletes this node completely by grabbing the parents
 118 # and deleting me from them, then deleting me from all the
 119 # dependent nodes.
 120 sub delete
 121 {
 122         my $self = shift;
 123         my @out;
 124         my $ncall = $self->{call};
 125
 126         # get rid of users and parents
 127         $self->_del_users;
 128         if (@{$self->{parent}}) {
 129                 foreach my $call (@{$self->{parent}}) {
 130                         my $parent = Route::Node::get($call);
 131                         push @out, $parent->del($self) if $parent;
 132                 }
 133         }
 134         # get rid of my nodes
 135         push @out, $self->del_nodes;
 136         # this only happens if we a orphan with no parents
 137         if ($list{$ncall}) {
 138                 push @out, $self;
 139                 delete $list{$ncall};
 140         }
 141         return @out;
 142 }
 143
 144 sub del_nodes
 145 {
 146         my $parent = shift;
 147         my @out;
 148         foreach my $rcall (@{$parent->{nodes}}) {
 149                 my $r = get($rcall);
 150                 push @out, $r->del($parent, $parent->{call}, @_) if $r;
 151         }
 152         return @out;
 153 }
 154
 155 sub _del_users
 156 {
 157         my $self = shift;
 158         for (@{$self->{users}}) {
 159                 my $ref = Route::User::get($_);
 160                 $ref->del($self) if $ref;
 161         }
 162         $self->{users} = [];
 163 }
 164
 165 # add a user to this node
 166 sub add_user
 167 {
 168         my $self = shift;
 169         my $ucall = shift;
 170         my $here = shift;
 171         my $ip = shift;
 172
 173         confess "Trying to add NULL User call to routing tables" unless $ucall;
 174
 175         my $uref = Route::User::get($ucall);
 176         my @out;
 177         if ($uref) {
 178                 @out = $uref->addparent($self);
 179         } else {
 180                 $uref = Route::User->new($ucall, $self->{call}, $here, $ip);
 181                 @out = $uref;
 182         }
 183         $self->_adduser($uref);
 184         $self->{usercount} = scalar @{$self->{users}};
 185
 186         return @out;
 187 }
 188
 189 # delete a user from this node
 190 sub del_user
 191 {
 192         my $self = shift;
 193         my $ref = shift;
 194         my @out;
 195
 196         if ($ref) {
 197                 @out = $self->_deluser($ref);
 198                 $ref->del($self);
 199         } else {
 200                 confess "tried to delete non-existant $ref->{call} from $self->{call}";
 201         }
 202         $self->{usercount} = scalar @{$self->{users}};
 203         return @out;
 204 }
 205
 206 # is a user on this node
 207 sub is_user
 208 {
 209         my $self = shift;
 210         my $call = shift;
 211         return scalar grep {$_ eq $call} @{$self->{users}};
 212 }
 213
 214 sub usercount
 215 {
 216         my $self = shift;
 217         if (@_ && @{$self->{users}} == 0) {
 218                 $self->{usercount} = shift;
 219         }
 220         return $self->{usercount};
 221 }
 222
 223 sub users
 224 {
 225         my $self = shift;
 226         return @{$self->{users}};
 227 }
 228
 229 sub nodes
 230 {
 231         my $self = shift;
 232         return @{$self->{nodes}};
 233 }
 234
 235 sub rnodes
 236 {
 237         my $self = shift;
 238         my @out;
 239         foreach my $call (@{$self->{nodes}}) {
 240                 next if grep $call eq $_, @_;
 241                 push @out, $call;
 242                 my $r = get($call);
 243                 push @out, $r->rnodes($call, @_) if $r;
 244         }
 245         return @out;
 246 }
 247
 248 # this takes in a list of node and user calls (not references) from
 249 # a config type update for a node and returns
 250 # the differences as lists of things that have gone away
 251 # and things that have been added.
 252 sub calc_config_changes
 253 {
 254         my $self = shift;
 255         my %nodes = map {$_ => 1} @{$self->{nodes}};
 256         my %users = map {$_ => 1} @{$self->{users}};
 257         my $cnodes = shift;
 258         my $cusers = shift;
 259         if (isdbg('route')) {
 260                 dbg("ROUTE: start calc_config_changes");
 261                 dbg("ROUTE: incoming nodes on $self->{call}: " . join(',', sort @$cnodes));
 262                 dbg("ROUTE: incoming users on $self->{call}: " . join(',', sort @$cusers));
 263                 dbg("ROUTE: existing nodes on $self->{call}: " . join(',', sort keys %nodes));
 264                 dbg("ROUTE: existing users on $self->{call}: " . join(',', sort keys %users));
 265         }
 266         my (@dnodes, @dusers, @nnodes, @nusers);
 267         push @nnodes, map {my @r = $nodes{$_} ? () : $_; delete $nodes{$_}; @r} @$cnodes;
 268         push @dnodes, keys %nodes;
 269         push @nusers, map {my @r = $users{$_} ? () : $_; delete $users{$_}; @r} @$cusers;
 270         push @dusers, keys %users;
 271         if (isdbg('route')) {
 272                 dbg("ROUTE: deleted nodes on $self->{call}: " . join(',', sort @dnodes));
 273                 dbg("ROUTE: deleted users on $self->{call}: " . join(',', sort @dusers));
 274                 dbg("ROUTE: added nodes on $self->{call}: " . join(',', sort  @nnodes));
 275                 dbg("ROUTE: added users on $self->{call}: " . join(',', sort @nusers));
 276                 dbg("ROUTE: end calc_config_changes");
 277         }
 278         return (\@dnodes, \@dusers, \@nnodes, \@nusers);
 279 }
 280
 281
 282 sub new
 283 {
 284         my $pkg = shift;
 285         my $call = uc shift;
 286
 287         confess "already have $call in $pkg" if $list{$call};
 288
 289         my $self = $pkg->SUPER::new($call);
 290         $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ];
 291         $self->{version} = shift || 5401;
 292         $self->{flags} = shift || Route::here(1);
 293         $self->{users} = [];
 294         $self->{nodes} = [];
 295         $self->{PC92C_dxchan} = {};
 296         my $ip = shift;
 297         $self->{ip} = $ip if defined $ip;
 298         $self->reset_obs;                       # by definition
 299
 300         $list{$call} = $self;
 301
 302         return $self;
 303 }
 304
 305 sub get
 306 {
 307         my $call = shift;
 308         $call = shift if ref $call;
 309         my $ref = $list{uc $call};
 310         dbg("ROUTE: Failed to get Node $call" ) if !$ref && isdbg('routerr');
 311         return $ref;
 312 }
 313
 314 sub get_all
 315 {
 316         return values %list;
 317 }
 318
 319 sub _addparent
 320 {
 321         my $self = shift;
 322     return $self->_addlist('parent', @_);
 323 }
 324
 325 sub _delparent
 326 {
 327         my $self = shift;
 328     return $self->_dellist('parent', @_);
 329 }
 330
 331
 332 sub _addnode
 333 {
 334         my $self = shift;
 335     return $self->_addlist('nodes', @_);
 336 }
 337
 338 sub _delnode
 339 {
 340         my $self = shift;
 341     return $self->_dellist('nodes', @_);
 342 }
 343
 344
 345 sub _adduser
 346 {
 347         my $self = shift;
 348     return $self->_addlist('users', @_);
 349 }
 350
 351 sub _deluser
 352 {
 353         my $self = shift;
 354     return $self->_dellist('users', @_);
 355 }
 356
 357 sub dec_obs
 358 {
 359         my $self = shift;
 360         $self->{obscount}--;
 361         return $self->{obscount};
 362 }
 363
 364 sub reset_obs
 365 {
 366         my $self = shift;
 367         $self->{obscount} = $obscount;
 368 }
 369
 370 sub measure_pc9x_t
 371 {
 372         my $parent = shift;
 373         my $t = shift;
 374         my $lastid = $parent->{lastid};
 375         if ($lastid) {
 376                 return ($t < $lastid) ? $t+86400-$lastid : $t - $lastid;
 377         } else {
 378                 return 86400;
 379         }
 380 }
 381
 382 sub PC92C_dxchan
 383 {
 384         my $parent = shift;
 385         my $call = shift;
 386         my $hops = shift;
 387         if ($call && $hops) {
 388                 $hops =~ s/^H//;
 389                 $parent->{PC92C_dxchan}->{$call} = $hops;
 390                 return;
 391         }
 392         return (%{$parent->{PC92C_dxchan}});
 393 }
 394
 395 sub DESTROY
 396 {
 397         my $self = shift;
 398         my $pkg = ref $self;
 399         my $call = $self->{call} || "Unknown";
 400
 401         dbg("ROUTE: destroying $pkg with $call") if isdbg('routelow');
 402 }
 403
 404 #
 405 # generic AUTOLOAD for accessors
 406 #
 407
 408 sub AUTOLOAD
 409 {
 410         no strict;
 411         my $name = $AUTOLOAD;
 412         return if $name =~ /::DESTROY$/;
 413         $name =~ s/^.*:://o;
 414
 415         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 416
 417         # this clever line of code creates a subroutine which takes over from autoload
 418         # from OO Perl - Conway
 419         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 420         goto &$AUTOLOAD;
 421 }
 422
 423 1;
 424