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