]> dxcluster.org Git - spider.git/blob - perl/RouteDB.pm
try to fix the gtkconsole CVS version no
[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(%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;