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 use DXJSON;
  16 use Time::HiRes qw(gettimeofday);
  17
  18 use strict;
  19
  20 use vars qw(%list %valid @ISA $max $filterdef $obscount);
  21 @ISA = qw(Route);
  22
  23 %valid = (
  24                   K => '9,Seen on PC92K,yesno',
  25                   PC92C_dxchan => '9,PC92C hops,phash',
  26                   build => '0,Build',
  27                   do_pc9x => '0,Uses pc9x,yesno',
  28                   handle_xml => '0,Using XML,yesno',
  29                   last_PC92C => '9,Last PC92C',
  30                   lastid => '0,Last Route MsgID',
  31                   lastmsg => '0,Last Route Msg,atime',
  32                   nodes => '0,Nodes,parray',
  33                   obscount => '0,Obscount',
  34                   usercount => '0,User Count',
  35                   users => '0,Users,parray',
  36                   version => '0,Version',
  37                   via_pc92 => '0,In via pc92?,yesno',
  38 );
  39
  40 $filterdef = $Route::filterdef;
  41 %list = ();
  42 $max = 0;
  43 $obscount = 3;
  44 our $cachefn = localdata('route_node_cache');
  45
  46 sub count
  47 {
  48         my $n = scalar (keys %list);
  49         $max = $n if $n > $max;
  50         return $n;
  51 }
  52
  53 sub max
  54 {
  55         count();
  56         return $max;
  57 }
  58
  59 #
  60 # this routine handles the possible adding of an entry in the routing
  61 # table. It will only add an entry if it is new. It may have all sorts of
  62 # other side effects which may include fixing up other links.
  63 #
  64 # It will return a node object if (and only if) it is a completely new
  65 # object with that callsign. The upper layers are expected to do something
  66 # sensible with this!
  67 #
  68 # called as $parent->add(call, dxchan, version, flags)
  69 #
  70
  71 sub add
  72 {
  73         my $parent = shift;
  74         my $call = uc shift;
  75         confess "Route::add trying to add $call to myself" if $call eq $parent->{call};
  76         my $self = get($call);
  77         if ($self) {
  78                 $self->_addparent($parent);
  79                 $parent->_addnode($self);
  80                 return undef;
  81         }
  82         $self = $parent->new($call, @_);
  83         $parent->_addnode($self);
  84         dbg("CLUSTER: node $call added") if isdbg('cluster');
  85         return $self;
  86 }
  87
  88 #
  89 # this routine is the opposite of 'add' above.
  90 #
  91 # It will return an object if (and only if) this 'del' will remove
  92 # this object completely
  93 #
  94
  95 sub del
  96 {
  97         my $self = shift;
  98         my $pref = shift;
  99
 100         # delete parent from this call's parent list
 101         $pref->_delnode($self);
 102     $self->_delparent($pref);
 103         my @nodes;
 104         my $ncall = $self->{call};
 105
 106         # is this the last connection, I have no parents anymore?
 107         unless (@{$self->{parent}}) {
 108                 foreach my $rcall (@{$self->{nodes}}) {
 109                         next if grep $rcall eq $_, @_;
 110                         my $r = Route::Node::get($rcall);
 111                         push @nodes, $r->del($self, $ncall, @_) if $r;
 112                 }
 113                 $self->_del_users;
 114                 delete $list{$ncall};
 115                 push @nodes, $self;
 116                 dbg("CLUSTER: node $ncall deleted") if isdbg('cluster');
 117         }
 118         return @nodes;
 119 }
 120
 121 # this deletes this node completely by grabbing the parents
 122 # and deleting me from them, then deleting me from all the
 123 # dependent nodes.
 124 sub delete
 125 {
 126         my $self = shift;
 127         my @out;
 128         my $ncall = $self->{call};
 129
 130         # get rid of users and parents
 131         $self->_del_users;
 132         if (@{$self->{parent}}) {
 133                 foreach my $call (@{$self->{parent}}) {
 134                         my $parent = Route::Node::get($call);
 135                         push @out, $parent->del($self) if $parent;
 136                 }
 137         }
 138         # get rid of my nodes
 139         push @out, $self->del_nodes;
 140         # this only happens if we a orphan with no parents
 141         if ($list{$ncall}) {
 142                 push @out, $self;
 143                 delete $list{$ncall};
 144         }
 145         return @out;
 146 }
 147
 148 sub del_nodes
 149 {
 150         my $parent = shift;
 151         my @out;
 152         foreach my $rcall (@{$parent->{nodes}}) {
 153                 my $r = get($rcall);
 154                 push @out, $r->del($parent, $parent->{call}, @_) if $r;
 155         }
 156         return @out;
 157 }
 158
 159 sub _del_users
 160 {
 161         my $self = shift;
 162         for (@{$self->{users}}) {
 163                 my $ref = Route::User::get($_);
 164                 $ref->del($self) if $ref;
 165         }
 166         $self->{users} = [];
 167 }
 168
 169 # add a user to this node
 170 sub add_user
 171 {
 172         my $self = shift;
 173         my $ucall = shift;
 174         my $here = shift;
 175         my $ip = shift;
 176
 177         confess "Trying to add NULL User call to routing tables" unless $ucall;
 178
 179         my $uref = Route::User::get($ucall);
 180         my @out;
 181         if ($uref) {
 182                 @out = $uref->addparent($self);
 183         } else {
 184                 $uref = Route::User->new($ucall, $self->{call}, $here, $ip);
 185                 @out = $uref;
 186         }
 187         $self->_adduser($uref);
 188         $self->{usercount} = scalar @{$self->{users}};
 189
 190         return @out;
 191 }
 192
 193 # delete a user from this node
 194 sub del_user
 195 {
 196         my $self = shift;
 197         my $ref = shift;
 198         my @out;
 199
 200         if ($ref) {
 201                 @out = $self->_deluser($ref);
 202                 $ref->del($self);
 203         } else {
 204                 confess "tried to delete non-existant $ref->{call} from $self->{call}";
 205         }
 206         $self->{usercount} = scalar @{$self->{users}};
 207         return @out;
 208 }
 209
 210 # is a user on this node
 211 sub is_user
 212 {
 213         my $self = shift;
 214         my $call = shift;
 215         return scalar grep {$_ eq $call} @{$self->{users}};
 216 }
 217
 218 sub usercount
 219 {
 220         my $self = shift;
 221         if (@_ && @{$self->{users}} == 0) {
 222                 $self->{usercount} = shift;
 223         }
 224         return $self->{usercount};
 225 }
 226
 227 sub users
 228 {
 229         my $self = shift;
 230         return @{$self->{users}};
 231 }
 232
 233 sub nodes
 234 {
 235         my $self = shift;
 236         return @{$self->{nodes}};
 237 }
 238
 239 sub rnodes
 240 {
 241         my $self = shift;
 242         my @out;
 243         foreach my $call (@{$self->{nodes}}) {
 244                 next if grep $call eq $_, @_;
 245                 push @out, $call;
 246                 my $r = get($call);
 247                 push @out, $r->rnodes($call, @_) if $r;
 248         }
 249         return @out;
 250 }
 251
 252 # this takes in a list of node and user calls (not references) from
 253 # a config type update for a node and returns
 254 # the differences as lists of things that have gone away
 255 # and things that have been added.
 256 sub calc_config_changes
 257 {
 258         my $self = shift;
 259         my %nodes = map {$_ => 1} @{$self->{nodes}};
 260         my %users = map {$_ => 1} @{$self->{users}};
 261         my $cnodes = shift;
 262         my $cusers = shift;
 263         if (isdbg('route')) {
 264                 dbg("ROUTE: start calc_config_changes");
 265                 dbg("ROUTE: incoming nodes on $self->{call}: " . join(',', sort @$cnodes));
 266                 dbg("ROUTE: incoming users on $self->{call}: " . join(',', sort @$cusers));
 267                 dbg("ROUTE: existing nodes on $self->{call}: " . join(',', sort keys %nodes));
 268                 dbg("ROUTE: existing users on $self->{call}: " . join(',', sort keys %users));
 269         }
 270         my (@dnodes, @dusers, @nnodes, @nusers);
 271         push @nnodes, map {my @r = $nodes{$_} ? () : $_; delete $nodes{$_}; @r} @$cnodes;
 272         push @dnodes, keys %nodes;
 273         push @nusers, map {my @r = $users{$_} ? () : $_; delete $users{$_}; @r} @$cusers;
 274         push @dusers, keys %users;
 275         if (isdbg('route')) {
 276                 dbg("ROUTE: deleted nodes on $self->{call}: " . join(',', sort @dnodes));
 277                 dbg("ROUTE: deleted users on $self->{call}: " . join(',', sort @dusers));
 278                 dbg("ROUTE: added nodes on $self->{call}: " . join(',', sort  @nnodes));
 279                 dbg("ROUTE: added users on $self->{call}: " . join(',', sort @nusers));
 280                 dbg("ROUTE: end calc_config_changes");
 281         }
 282         return (\@dnodes, \@dusers, \@nnodes, \@nusers);
 283 }
 284
 285
 286 sub new
 287 {
 288         my $pkg = shift;
 289         my $call = uc shift;
 290
 291         confess "already have $call in $pkg" if $list{$call};
 292
 293         my $self = $pkg->SUPER::new($call);
 294         $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ];
 295         $self->{version} = shift || 5401;
 296         $self->{flags} = shift || Route::here(1);
 297         $self->{users} = [];
 298         $self->{nodes} = [];
 299         $self->{PC92C_dxchan} = {};
 300         my $ip = shift;
 301         $self->{ip} = $ip if defined $ip;
 302         $self->reset_obs;                       # by definition
 303
 304         $list{$call} = $self;
 305
 306         return $self;
 307 }
 308
 309 sub get
 310 {
 311         my $call = shift;
 312         $call = shift if ref $call;
 313         my $ref = $list{uc $call};
 314         dbg("ROUTE: Failed to get Node $call" ) if !$ref && isdbg('routerr');
 315         return $ref;
 316 }
 317
 318 sub get_all
 319 {
 320         return values %list;
 321 }
 322
 323 sub _addparent
 324 {
 325         my $self = shift;
 326     return $self->_addlist('parent', @_);
 327 }
 328
 329 sub _delparent
 330 {
 331         my $self = shift;
 332     return $self->_dellist('parent', @_);
 333 }
 334
 335
 336 sub _addnode
 337 {
 338         my $self = shift;
 339     return $self->_addlist('nodes', @_);
 340 }
 341
 342 sub _delnode
 343 {
 344         my $self = shift;
 345     return $self->_dellist('nodes', @_);
 346 }
 347
 348
 349 sub _adduser
 350 {
 351         my $self = shift;
 352     return $self->_addlist('users', @_);
 353 }
 354
 355 sub _deluser
 356 {
 357         my $self = shift;
 358     return $self->_dellist('users', @_);
 359 }
 360
 361 sub dec_obs
 362 {
 363         my $self = shift;
 364         $self->{obscount}--;
 365         return $self->{obscount};
 366 }
 367
 368 sub reset_obs
 369 {
 370         my $self = shift;
 371         $self->{obscount} = $obscount;
 372 }
 373
 374 sub measure_pc9x_t
 375 {
 376         my $parent = shift;
 377         my $t = shift;
 378         my $lastid = $parent->{lastid};
 379         if ($lastid) {
 380                 return ($t < $lastid) ? $t+86400-$lastid : $t - $lastid;
 381         } else {
 382                 return 86400;
 383         }
 384 }
 385
 386 sub PC92C_dxchan
 387 {
 388         my $parent = shift;
 389         my $call = shift;
 390         my $hops = shift;
 391         if ($call && $hops) {
 392                 $hops =~ s/^H//;
 393                 $parent->{PC92C_dxchan}->{$call} = $hops;
 394                 return;
 395         }
 396         return (%{$parent->{PC92C_dxchan}});
 397 }
 398
 399 sub TO_JSON { return { %{ shift() } }; }
 400
 401 sub write_cache
 402 {
 403         my $json = DXJSON->new;
 404         $json->canonical(isdbg('routecache')||0);
 405
 406         my $ta = [ gettimeofday ];
 407         my @s;
 408         eval {
 409                 while (my ($k, $v) = each  %list) {
 410                     push @s, "$k:" . $json->encode($v) . "\n";
 411             }
 412         };
 413         if (!$@ && @s) {
 414                 my $fh = IO::File->new(">$cachefn") or dbg("Route::Node: Error writing $cachefn $!"), return;
 415                 print $fh "$_" for (sort @s);
 416                 $fh->close;
 417         } else {
 418                 dbg("Route::Node::write_cache error '$@'");
 419                 return;
 420         }
 421         $json->indent(0)->canonical(0);
 422         my $diff = _diffms($ta);
 423         dbg("Route::Node::write_cache time to write: $diff mS");
 424 }
 425
 426 sub read_cache
 427 {
 428         my $json = DXJSON->new;
 429         $json->canonical(isdbg('routecache'));
 430
 431         my $ta = [ gettimeofday ];
 432         my $count;
 433
 434         my $fh = IO::File->new("$cachefn") or dbg("Route::Node ERROR reading $cachefn $!"), return;
 435         while (my $l = <$fh>) {
 436                 chomp $l;
 437                 my ($k, $v) = split /:/, $l, 2;
 438                 $list{$k} = bless $json->decode($v) or carp("Route::Node json error $! decoding '$v'"), next;
 439                 ++$count;
 440         }
 441         $fh->close if $fh;;
 442
 443         my $diff = _diffms($ta);
 444         dbg("Route::Node::read_cache time to read $count records from $cachefn : $diff mS");
 445 }
 446
 447 sub DESTROY
 448 {
 449         my $self = shift;
 450         my $pkg = ref $self;
 451         my $call = $self->{call} || "Unknown";
 452
 453         dbg("ROUTE: destroying $pkg with $call") if isdbg('routelow');
 454 }
 455
 456 #
 457 # generic AUTOLOAD for accessors
 458 #
 459
 460 sub AUTOLOAD
 461 {
 462         no strict;
 463         my $name = $AUTOLOAD;
 464         return if $name =~ /::DESTROY$/;
 465         $name =~ s/^.*:://o;
 466
 467         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 468
 469         # this clever line of code creates a subroutine which takes over from autoload
 470         # from OO Perl - Conway
 471         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 472         goto &$AUTOLOAD;
 473 }
 474
 475 1;
 476