X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FRoute%2FNode.pm;h=e2b154169b38b0cdc0a062508ee91dba42563776;hb=f63d598af3f797b56b8d5e23ec4ff5254192eee9;hp=6181e2d819e60fd7e6b27ad01f9985f95a33f4de;hpb=d2580480d24be5e8f1beb4aeeb40980db0dedde0;p=spider.git diff --git a/perl/Route/Node.pm b/perl/Route/Node.pm index 6181e2d8..e2b15416 100644 --- a/perl/Route/Node.pm +++ b/perl/Route/Node.pm @@ -1 +1,425 @@ -## Node routing routines## Copyright (c) 2001 Dirk Koopman G1TLH## $Id$#package Route::Node;use DXDebug;use Route;use Route::User;use DXUtil;use strict;use vars qw(%list %valid @ISA $max $filterdef $obscount);@ISA = qw(Route);%valid = ( parent => '0,Parent Calls,parray', nodes => '0,Nodes,parray', users => '0,Users,parray', usercount => '0,User Count', version => '0,Version', handle_xml => '0,Using XML,yesno', lastmsg => '0,Last Route Msg,atime', lastid => '0,Last Route MsgID', do_pc9x => '0,Uses pc9x,yesno', via_pc92 => '0,Came in via pc92,yesno', obscount => '0,Obscount',);$filterdef = $Route::filterdef;%list = ();$max = 0;$obscount = 3;sub count{ my $n = scalar (keys %list); $max = $n if $n > $max; return $n;}sub max{ count(); return $max;}## this routine handles the possible adding of an entry in the routing# table. It will only add an entry if it is new. It may have all sorts of# other side effects which may include fixing up other links.## It will return a node object if (and only if) it is a completely new# object with that callsign. The upper layers are expected to do something# sensible with this!## called as $parent->add(call, dxchan, version, flags)#sub add{ my $parent = shift; my $call = uc shift; confess "Route::add trying to add $call to myself" if $call eq $parent->{call}; my $self = get($call); if ($self) { $self->_addparent($parent); $parent->_addnode($self); return undef; } $self = $parent->new($call, @_); $parent->_addnode($self); return $self;}## this routine is the opposite of 'add' above.## It will return an object if (and only if) this 'del' will remove# this object completely#sub del{ my $self = shift; my $pref = shift; # delete parent from this call's parent list $pref->_delnode($self); $self->_delparent($pref); my @nodes; my $ncall = $self->{call}; # is this the last connection, I have no parents anymore? unless (@{$self->{parent}}) { foreach my $rcall (@{$self->{nodes}}) { next if grep $rcall eq $_, @_; my $r = Route::Node::get($rcall); push @nodes, $r->del($self, $ncall, @_) if $r; } $self->_del_users; delete $list{$self->{call}}; push @nodes, $self; } return @nodes;}# this deletes this node completely by grabbing the parents# and deleting me from themsub delete{ my $self = shift; my @out; $self->_del_users; foreach my $call (@{$self->{parent}}) { my $parent = Route::Node::get($call); push @out, $parent->del($self) if $parent; } return @out;}sub del_nodes{ my $parent = shift; my @out; foreach my $rcall (@{$parent->{nodes}}) { my $r = get($rcall); push @out, $r->del($parent, $parent->{call}, @_) if $r; } return @out;}sub _del_users{ my $self = shift; for (@{$self->{users}}) { my $ref = Route::User::get($_); $ref->del($self) if $ref; } $self->{users} = [];}# add a user to this nodesub add_user{ my $self = shift; my $ucall = shift; confess "Trying to add NULL User call to routing tables" unless $ucall; my $uref = Route::User::get($ucall); my @out; if ($uref) { @out = $uref->addparent($self); } else { $uref = Route::User->new($ucall, $self->{call}, @_); @out = $uref; } $self->_adduser($uref); $self->{usercount} = scalar @{$self->{users}}; return @out;}# delete a user from this nodesub del_user{ my $self = shift; my $ref = shift; my @out; if ($ref) { @out = $self->_deluser($ref); $ref->del($self); } else { confess "tried to delete non-existant $ref->{call} from $self->{call}"; } $self->{usercount} = scalar @{$self->{users}}; return @out;}sub usercount{ my $self = shift; if (@_ && @{$self->{users}} == 0) { $self->{usercount} = shift; } return $self->{usercount};}sub users{ my $self = shift; return @{$self->{users}};}sub nodes{ my $self = shift; return @{$self->{nodes}};}sub parents{ my $self = shift; return @{$self->{parent}};}sub rnodes{ my $self = shift; my @out; foreach my $call (@{$self->{nodes}}) { next if grep $call eq $_, @_; push @out, $call; my $r = get($call); push @out, $r->rnodes($call, @_) if $r; } return @out;}# this takes in a list of node and user calls (not references) from# a config type update for a node and returns# the differences as lists of things that have gone away# and things that have been added.sub calc_config_changes{ my $self = shift; my %nodes = map {$_ => 1} @{$self->{nodes}}; my %users = map {$_ => 1} @{$self->{users}}; my $cnodes = shift; my $cusers = shift; if (isdbg('route')) { dbg("ROUTE: start calc_config_changes"); dbg("ROUTE: incoming nodes on $self->{call}: " . join(',', sort @$cnodes)); dbg("ROUTE: incoming users on $self->{call}: " . join(',', sort @$cusers)); dbg("ROUTE: existing nodes on $self->{call}: " . join(',', sort keys %nodes)); dbg("ROUTE: existing users on $self->{call}: " . join(',', sort keys %users)); } my (@dnodes, @dusers, @nnodes, @nusers); push @nnodes, map {my @r = $nodes{$_} ? () : $_; delete $nodes{$_}; @r} @$cnodes; push @dnodes, keys %nodes; push @nusers, map {my @r = $users{$_} ? () : $_; delete $users{$_}; @r} @$cusers; push @dusers, keys %users; if (isdbg('route')) { dbg("ROUTE: deleted nodes on $self->{call}: " . join(',', sort @dnodes)); dbg("ROUTE: deleted users on $self->{call}: " . join(',', sort @dusers)); dbg("ROUTE: added nodes on $self->{call}: " . join(',', sort @nnodes)); dbg("ROUTE: added users on $self->{call}: " . join(',', sort @nusers)); dbg("ROUTE: end calc_config_changes"); } return (\@dnodes, \@dusers, \@nnodes, \@nusers);}sub new{ my $pkg = shift; my $call = uc shift; confess "already have $call in $pkg" if $list{$call}; my $self = $pkg->SUPER::new($call); $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ]; $self->{version} = shift || 5401; $self->{flags} = shift || Route::here(1); $self->{users} = []; $self->{nodes} = []; $self->{lastid} = {}; $self->reset_obs; # by definition $list{$call} = $self; return $self;}sub get{ my $call = shift; $call = shift if ref $call; my $ref = $list{uc $call}; dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr'); return $ref;}sub get_all{ return values %list;}sub _addparent{ my $self = shift; return $self->_addlist('parent', @_);}sub _delparent{ my $self = shift; return $self->_dellist('parent', @_);}sub _addnode{ my $self = shift; return $self->_addlist('nodes', @_);}sub _delnode{ my $self = shift; return $self->_dellist('nodes', @_);}sub _adduser{ my $self = shift; return $self->_addlist('users', @_);}sub _deluser{ my $self = shift; return $self->_dellist('users', @_);}sub dec_obs{ my $self = shift; $self->{obscount}--; return $self->{obscount};}sub reset_obs{ my $self = shift; $self->{obscount} = $obscount;}sub DESTROY{ my $self = shift; my $pkg = ref $self; my $call = $self->{call} || "Unknown"; dbg("destroying $pkg with $call") if isdbg('routelow');}## generic AUTOLOAD for accessors#sub AUTOLOAD{ no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}}; goto &$AUTOLOAD;}1; \ No newline at end of file +# +# Node routing routines +# +# Copyright (c) 2001 Dirk Koopman G1TLH +# +# +# + +package Route::Node; + +use DXDebug; +use Route; +use Route::User; +use DXUtil; + +use strict; + +use vars qw(%list %valid @ISA $max $filterdef $obscount); +@ISA = qw(Route); + +%valid = ( + K => '9,Seen on PC92K,yesno', + nodes => '0,Nodes,parray', + users => '0,Users,parray', + usercount => '0,User Count', + version => '0,Version', + build => '0,Build', + handle_xml => '0,Using XML,yesno', + lastmsg => '0,Last Route Msg,atime', + lastid => '0,Last Route MsgID', + do_pc9x => '0,Uses pc9x,yesno', + via_pc92 => '0,In via pc92?,yesno', + obscount => '0,Obscount', + last_PC92C => '9,Last PC92C', + PC92C_dxchan => '9,PC92C hops,phash', +); + +$filterdef = $Route::filterdef; +%list = (); +$max = 0; +$obscount = 3; + +sub count +{ + my $n = scalar (keys %list); + $max = $n if $n > $max; + return $n; +} + +sub max +{ + count(); + return $max; +} + +# +# this routine handles the possible adding of an entry in the routing +# table. It will only add an entry if it is new. It may have all sorts of +# other side effects which may include fixing up other links. +# +# It will return a node object if (and only if) it is a completely new +# object with that callsign. The upper layers are expected to do something +# sensible with this! +# +# called as $parent->add(call, dxchan, version, flags) +# + +sub add +{ + my $parent = shift; + my $call = uc shift; + confess "Route::add trying to add $call to myself" if $call eq $parent->{call}; + my $self = get($call); + if ($self) { + $self->_addparent($parent); + $parent->_addnode($self); + return undef; + } + $self = $parent->new($call, @_); + $parent->_addnode($self); + dbg("CLUSTER: node $call added") if isdbg('cluster'); + return $self; +} + +# +# this routine is the opposite of 'add' above. +# +# It will return an object if (and only if) this 'del' will remove +# this object completely +# + +sub del +{ + my $self = shift; + my $pref = shift; + + # delete parent from this call's parent list + $pref->_delnode($self); + $self->_delparent($pref); + my @nodes; + my $ncall = $self->{call}; + + # is this the last connection, I have no parents anymore? + unless (@{$self->{parent}}) { + foreach my $rcall (@{$self->{nodes}}) { + next if grep $rcall eq $_, @_; + my $r = Route::Node::get($rcall); + push @nodes, $r->del($self, $ncall, @_) if $r; + } + $self->_del_users; + delete $list{$ncall}; + push @nodes, $self; + dbg("CLUSTER: node $ncall deleted") if isdbg('cluster'); + } + return @nodes; +} + +# this deletes this node completely by grabbing the parents +# and deleting me from them, then deleting me from all the +# dependent nodes. +sub delete +{ + my $self = shift; + my @out; + my $ncall = $self->{call}; + + # get rid of users and parents + $self->_del_users; + if (@{$self->{parent}}) { + foreach my $call (@{$self->{parent}}) { + my $parent = Route::Node::get($call); + push @out, $parent->del($self) if $parent; + } + } + # get rid of my nodes + push @out, $self->del_nodes; + # this only happens if we a orphan with no parents + if ($list{$ncall}) { + push @out, $self; + delete $list{$ncall}; + } + return @out; +} + +sub del_nodes +{ + my $parent = shift; + my @out; + foreach my $rcall (@{$parent->{nodes}}) { + my $r = get($rcall); + push @out, $r->del($parent, $parent->{call}, @_) if $r; + } + return @out; +} + +sub _del_users +{ + my $self = shift; + for (@{$self->{users}}) { + my $ref = Route::User::get($_); + $ref->del($self) if $ref; + } + $self->{users} = []; +} + +# add a user to this node +sub add_user +{ + my $self = shift; + my $ucall = shift; + my $here = shift; + my $ip = shift; + + confess "Trying to add NULL User call to routing tables" unless $ucall; + + my $uref = Route::User::get($ucall); + my @out; + if ($uref) { + @out = $uref->addparent($self); + } else { + $uref = Route::User->new($ucall, $self->{call}, $here, $ip); + @out = $uref; + } + $self->_adduser($uref); + $self->{usercount} = scalar @{$self->{users}}; + + return @out; +} + +# delete a user from this node +sub del_user +{ + my $self = shift; + my $ref = shift; + my @out; + + if ($ref) { + @out = $self->_deluser($ref); + $ref->del($self); + } else { + confess "tried to delete non-existant $ref->{call} from $self->{call}"; + } + $self->{usercount} = scalar @{$self->{users}}; + return @out; +} + +# is a user on this node +sub is_user +{ + my $self = shift; + my $call = shift; + return scalar grep {$_ eq $call} @{$self->{users}}; +} + +sub usercount +{ + my $self = shift; + if (@_ && @{$self->{users}} == 0) { + $self->{usercount} = shift; + } + return $self->{usercount}; +} + +sub users +{ + my $self = shift; + return @{$self->{users}}; +} + +sub nodes +{ + my $self = shift; + return @{$self->{nodes}}; +} + +sub rnodes +{ + my $self = shift; + my @out; + foreach my $call (@{$self->{nodes}}) { + next if grep $call eq $_, @_; + push @out, $call; + my $r = get($call); + push @out, $r->rnodes($call, @_) if $r; + } + return @out; +} + +# this takes in a list of node and user calls (not references) from +# a config type update for a node and returns +# the differences as lists of things that have gone away +# and things that have been added. +sub calc_config_changes +{ + my $self = shift; + my %nodes = map {$_ => 1} @{$self->{nodes}}; + my %users = map {$_ => 1} @{$self->{users}}; + my $cnodes = shift; + my $cusers = shift; + if (isdbg('route')) { + dbg("ROUTE: start calc_config_changes"); + dbg("ROUTE: incoming nodes on $self->{call}: " . join(',', sort @$cnodes)); + dbg("ROUTE: incoming users on $self->{call}: " . join(',', sort @$cusers)); + dbg("ROUTE: existing nodes on $self->{call}: " . join(',', sort keys %nodes)); + dbg("ROUTE: existing users on $self->{call}: " . join(',', sort keys %users)); + } + my (@dnodes, @dusers, @nnodes, @nusers); + push @nnodes, map {my @r = $nodes{$_} ? () : $_; delete $nodes{$_}; @r} @$cnodes; + push @dnodes, keys %nodes; + push @nusers, map {my @r = $users{$_} ? () : $_; delete $users{$_}; @r} @$cusers; + push @dusers, keys %users; + if (isdbg('route')) { + dbg("ROUTE: deleted nodes on $self->{call}: " . join(',', sort @dnodes)); + dbg("ROUTE: deleted users on $self->{call}: " . join(',', sort @dusers)); + dbg("ROUTE: added nodes on $self->{call}: " . join(',', sort @nnodes)); + dbg("ROUTE: added users on $self->{call}: " . join(',', sort @nusers)); + dbg("ROUTE: end calc_config_changes"); + } + return (\@dnodes, \@dusers, \@nnodes, \@nusers); +} + + +sub new +{ + my $pkg = shift; + my $call = uc shift; + + confess "already have $call in $pkg" if $list{$call}; + + my $self = $pkg->SUPER::new($call); + $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ]; + $self->{version} = shift || 5401; + $self->{flags} = shift || Route::here(1); + $self->{users} = []; + $self->{nodes} = []; + $self->{PC92C_dxchan} = {}; + my $ip = shift; + $self->{ip} = $ip if defined $ip; + $self->reset_obs; # by definition + + $list{$call} = $self; + + return $self; +} + +sub get +{ + my $call = shift; + $call = shift if ref $call; + my $ref = $list{uc $call}; + dbg("ROUTE: Failed to get Node $call" ) if !$ref && isdbg('routerr'); + return $ref; +} + +sub get_all +{ + return values %list; +} + +sub _addparent +{ + my $self = shift; + return $self->_addlist('parent', @_); +} + +sub _delparent +{ + my $self = shift; + return $self->_dellist('parent', @_); +} + + +sub _addnode +{ + my $self = shift; + return $self->_addlist('nodes', @_); +} + +sub _delnode +{ + my $self = shift; + return $self->_dellist('nodes', @_); +} + + +sub _adduser +{ + my $self = shift; + return $self->_addlist('users', @_); +} + +sub _deluser +{ + my $self = shift; + return $self->_dellist('users', @_); +} + +sub dec_obs +{ + my $self = shift; + $self->{obscount}--; + return $self->{obscount}; +} + +sub reset_obs +{ + my $self = shift; + $self->{obscount} = $obscount; +} + +sub measure_pc9x_t +{ + my $parent = shift; + my $t = shift; + my $lastid = $parent->{lastid}; + if ($lastid) { + return ($t < $lastid) ? $t+86400-$lastid : $t - $lastid; + } else { + return 86400; + } +} + +sub PC92C_dxchan +{ + my $parent = shift; + my $call = shift; + my $hops = shift; + if ($call && $hops) { + $hops =~ s/^H//; + $parent->{PC92C_dxchan}->{$call} = $hops; + return; + } + return (%{$parent->{PC92C_dxchan}}); +} + +sub DESTROY +{ + my $self = shift; + my $pkg = ref $self; + my $call = $self->{call} || "Unknown"; + + dbg("ROUTE: destroying $pkg with $call") if isdbg('routelow'); +} + +# +# generic AUTOLOAD for accessors +# + +sub AUTOLOAD +{ + no strict; + my $name = $AUTOLOAD; + return if $name =~ /::DESTROY$/; + $name =~ s/^.*:://o; + + confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name}; + + # this clever line of code creates a subroutine which takes over from autoload + # from OO Perl - Conway + *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}}; + goto &$AUTOLOAD; +} + +1; +