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