perl/RouteDB.pm

   1 # This module is used to keep a list of where things come from
   2 #
   3 # all interfaces add/update entries in here to allow casual
   4 # routing to occur.
   5 #
   6 # It is up to the protocol handlers in here to make sure that
   7 # this information makes sense.
   8 #
   9 # This is (for now) just an adjunct to the normal routing
  10 # and is experimental. It will override filtering for
  11 # things that are explicitly routed (pings, talks and
  12 # such like).
  13 #
  14 # Copyright (c) 2004 Dirk Koopman G1TLH
  15 #
  16 # $Id$
  17 #
  18
  19 package RouteDB;
  20
  21 use DXDebug;
  22 use DXChannel;
  23 use DXUtil;
  24 use Prefix;
  25
  26 use strict;
  27
  28 use vars qw($VERSION $BRANCH);
  29 use vars qw(%list %valid $default);
  30
  31 ($VERSION, $BRANCH) = dxver(q$Revision$);
  32
  33 %list = ();
  34 $default = 99;                                  # the number of hops to use if we don't know
  35 %valid = (
  36                   call => "0,Callsign",
  37                   item => "0,Interfaces,parray",
  38                   t => '0,Last Seen,atime',
  39                   hops => '0,Hops',
  40                   count => '0,Times Seen',
  41                  );
  42
  43 sub new
  44 {
  45         my $pkg = shift;
  46         my $call = shift;
  47         return bless {call => $call, list => {}}, (ref $pkg || $pkg);
  48 }
  49
  50 # get the best one
  51 sub get
  52 {
  53         my @out = _sorted(shift);
  54         return @out ? $out[0]->{call} : undef;
  55 }
  56
  57 # get all of them in sorted order
  58 sub get_all
  59 {
  60         my @out = _sorted(shift);
  61         return @out ? map { $_->{call} } @out : ();
  62 }
  63
  64 # get them all, sorted into reverse occurance order (latest first)
  65 # with the smallest hops
  66 sub _sorted
  67 {
  68         my $call = shift;
  69         my $ref = $list{$call};
  70         return () unless $ref;
  71         return sort {
  72                 if ($a->{hops} == $b->{hops}) {
  73                         $b->{t} <=> $a->{t};
  74                 } else {
  75                         $a->{hops} <=> $b->{hops};
  76                 }
  77         } values %{$ref->{item}};
  78 }
  79
  80
  81 # add or update this call on this interface
  82 #
  83 # RouteDB::update($call, $interface, $hops, time);
  84 #
  85 sub update
  86 {
  87         my $call = shift;
  88         my $interface = shift;
  89         my $hops = shift || $default;
  90         my $ref = $list{$call} || RouteDB->new($call);
  91         my $iref = $ref->{item}->{$interface} ||= RouteDB::Item->new($interface, $hops);
  92         $iref->{count}++;
  93         $iref->{hops} = $hops if $hops < $iref->{hops};
  94         $iref->{t} = shift || $main::systime;
  95         $ref->{item}->{$interface} ||= $iref;
  96         $list{$call} ||= $ref;
  97 }
  98
  99 sub delete
 100 {
 101         my $call = shift;
 102         my $interface = shift;
 103         my $ref = $list{$call};
 104         delete $ref->{item}->{$interface} if $ref;
 105 }
 106
 107 sub delete_interface
 108 {
 109         my $interface = shift;
 110         foreach my $ref (values %list) {
 111                 delete $ref->{item}->{$interface};
 112         }
 113 }
 114
 115 #
 116 # generic AUTOLOAD for accessors
 117 #
 118 sub AUTOLOAD
 119 {
 120         no strict;
 121         my $name = $AUTOLOAD;
 122         return if $name =~ /::DESTROY$/;
 123         $name =~ s/^.*:://o;
 124
 125         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 126
 127         # this clever line of code creates a subroutine which takes over from autoload
 128         # from OO Perl - Conway
 129         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
 130        goto &$AUTOLOAD;
 131
 132 }
 133
 134 package RouteDB::Item;
 135
 136 use vars qw(@ISA);
 137 @ISA = qw(RouteDB);
 138
 139 sub new
 140 {
 141         my $pkg = shift;
 142         my $call = shift;
 143         my $hops = shift || $RouteDB::default;
 144         return bless {call => $call, hops => $hops}, (ref $pkg || $pkg);
 145 }
 146
 147 1;