]> dxcluster.net Git - spider.git/blob - perl/RouteDB.pm
fix divide by zero error
[spider.git] / 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
29 main::mkver($VERSION = q$Revision$);
30
31 use vars qw(%list %valid $default);
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);
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         return bless {call => $call, hops => $RouteDB::default}, (ref $pkg || $pkg);
144 }
145
146 1;