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 Prefix;
  24
  25 use strict;
  26
  27 use vars qw(%list %valid $default);
  28
  29 %list = ();
  30 $default = 99;                                  # the number of hops to use if we don't know
  31 %valid = (
  32                   call => "0,Callsign",
  33                   item => "0,Interfaces,parray",
  34                   t => '0,Last Seen,atime',
  35                   hops => '0,Hops',
  36                   count => '0,Times Seen',
  37                  );
  38
  39 sub new
  40 {
  41         my $pkg = shift;
  42         my $call = shift;
  43         return bless {call => $call, list => {}}, (ref $pkg || $pkg);
  44 }
  45
  46 # get the best one
  47 sub get
  48 {
  49         my @out = _sorted(shift);
  50         return @out ? $out[0]->{call} : undef;
  51 }
  52
  53 # get all of them in sorted order
  54 sub get_all
  55 {
  56         my @out = _sorted(shift);
  57         return @out ? map { $_->{call} } @out : ();
  58 }
  59
  60 # get them all, sorted into reverse occurance order (latest first)
  61 # with the smallest hops
  62 sub _sorted
  63 {
  64         my $call = shift;
  65         my $ref = $list{$call};
  66         return () unless $ref;
  67         return sort {
  68                 if ($a->{hops} == $b->{hops}) {
  69                         $b->{t} <=> $a->{t};
  70                 } else {
  71                         $a->{hops} <=> $b->{hops};
  72                 }
  73         } values %{$ref->{item}};
  74 }
  75
  76
  77 # add or update this call on this interface
  78 #
  79 # RouteDB::update($call, $interface, $hops, time);
  80 #
  81 sub update
  82 {
  83         my $call = shift;
  84         my $interface = shift;
  85         my $hops = shift || $default;
  86         my $ref = $list{$call} || RouteDB->new($call);
  87         my $iref = $ref->{item}->{$interface} ||= RouteDB::Item->new($interface);
  88         $iref->{count}++;
  89         $iref->{hops} = $hops if $hops < $iref->{hops};
  90         $iref->{t} = shift || $main::systime;
  91         $ref->{item}->{$interface} ||= $iref;
  92         $list{$call} ||= $ref;
  93 }
  94
  95 sub delete
  96 {
  97         my $call = shift;
  98         my $interface = shift;
  99         my $ref = $list{$call};
 100         delete $ref->{item}->{$interface} if $ref;
 101 }
 102
 103 sub delete_interface
 104 {
 105         my $interface = shift;
 106         foreach my $ref (values %list) {
 107                 delete $ref->{item}->{$interface};
 108         }
 109 }
 110
 111 #
 112 # generic AUTOLOAD for accessors
 113 #
 114 sub AUTOLOAD
 115 {
 116         no strict;
 117         my $name = $AUTOLOAD;
 118         return if $name =~ /::DESTROY$/;
 119         $name =~ s/^.*:://o;
 120
 121         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 122
 123         # this clever line of code creates a subroutine which takes over from autoload
 124         # from OO Perl - Conway
 125         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
 126        goto &$AUTOLOAD;
 127
 128 }
 129
 130 package RouteDB::Item;
 131
 132 use vars qw(@ISA);
 133 @ISA = qw(RouteDB);
 134
 135 sub new
 136 {
 137         my $pkg = shift;
 138         my $call = shift;
 139         return bless {call => $call, hops => $RouteDB::default}, (ref $pkg || $pkg);
 140 }
 141
 142 1;