]> dxcluster.net Git - spider.git/blob - perl/Route/Node.pm
e29fe3caefb1eeb393dd1322ff21f99ee3428888
[spider.git] / perl / Route / Node.pm
1 #
2 # Node routing routines
3 #
4 # Copyright (c) 2001 Dirk Koopman G1TLH
5 #
6 # $Id$
7
8
9 package Route::Node;
10
11 use DXDebug;
12 use Route;
13 use Route::User;
14
15 use strict;
16
17 use vars qw(%list %valid @ISA $max $filterdef);
18 @ISA = qw(Route);
19
20 %valid = (
21                   parent => '0,Parent Calls,parray',
22                   nodes => '0,Nodes,parray',
23                   users => '0,Users,parray',
24                   usercount => '0,User Count',
25                   version => '0,Version',
26 );
27
28 $filterdef = $Route::filterdef;
29 %list = ();
30 $max = 0;
31
32 sub count
33 {
34         my $n = scalar (keys %list);
35         $max = $n if $n > $max;
36         return $n;
37 }
38
39 sub max
40 {
41         return $max;
42 }
43
44 #
45 # this routine handles the possible adding of an entry in the routing
46 # table. It will only add an entry if it is new. It may have all sorts of
47 # other side effects which may include fixing up other links.
48 #
49 # It will return a node object if (and only if) it is a completely new
50 # object with that callsign. The upper layers are expected to do something
51 # sensible with this!
52 #
53 # called as $parent->add(call, dxchan, version, flags) 
54 #
55
56 sub add
57 {
58         my $parent = shift;
59         my $call = uc shift;
60         confess "Route::add trying to add $call to myself" if $call eq $parent->{call};
61         my $self = get($call);
62         if ($self) {
63                 $self->_addparent($parent->{call});
64                 $parent->_addnode($call);
65                 return undef;
66         }
67         $parent->_addnode($call);
68         $self = $parent->new($call, @_);
69         return $self;
70 }
71
72 #
73 # this routine is the opposite of 'add' above.
74 #
75 # It will return an object if (and only if) this 'del' will remove
76 # this object completely
77 #
78
79 sub del
80 {
81         my $self = shift;
82         my $pref = shift;
83
84         # delete parent from this call's parent list
85         my $pcall = $pref->{call};
86         my $ncall = $self->{call};
87         $pref->_delnode($ncall);;
88         my $ref = $self->_delparent($pcall);
89         my @nodes;
90         
91         # is this the last connection, I have no parents anymore?
92         unless (@$ref) {
93                 foreach my $rcall (@{$self->{nodes}}) {
94                         next if grep $rcall eq $_, @_;
95                         my $r = Route::Node::get($rcall);
96                         push @nodes, $r->del($self, $ncall, @_) if $r;
97                 }
98                 $self->_del_users;
99                 delete $list{$self->{call}};
100                 push @nodes, $self;
101         }
102         return @nodes;
103 }
104
105 sub del_nodes
106 {
107         my $parent = shift;
108         my @out;
109         foreach my $rcall (@{$parent->{nodes}}) {
110                 my $r = get($rcall);
111                 push @out, $r->del($parent, $parent->{call}, @_) if $r;
112         }
113         return @out;
114 }
115
116 sub _del_users
117 {
118         my $self = shift;
119         for (@{$self->{users}}) {
120                 my $ref = Route::User::get($_);
121                 $ref->del($self) if $ref;
122         }
123         $self->{users} = [];
124 }
125
126 # add a user to this node
127 sub add_user
128 {
129         my $self = shift;
130         my $ucall = shift;
131
132         confess "Trying to add NULL User call to routing tables" unless $ucall;
133
134         $self->_adduser($ucall);
135
136         $self->{usercount} = scalar @{$self->{users}};
137         my $uref = Route::User::get($ucall);
138         my @out;
139         if ($uref) {
140                 $uref->addparent($self->{call});
141         } else {
142                 @out = Route::User->new($ucall, $self->{call}, @_);
143         }
144         return @out;
145 }
146
147 # delete a user from this node
148 sub del_user
149 {
150         my $self = shift;
151         my $ucall = shift;
152         my $ref = Route::User::get($ucall);
153         $self->_deluser($ucall);
154         my @out = $ref->del($self) if $ref;
155         return @out;
156 }
157
158 sub usercount
159 {
160         my $self = shift;
161         if (@_ && @{$self->{users}} == 0) {
162                 $self->{usercount} = shift;
163         }
164         return $self->{usercount};
165 }
166
167 sub users
168 {
169         my $self = shift;
170         return @{$self->{users}};
171 }
172
173 sub nodes
174 {
175         my $self = shift;
176         return @{$self->{nodes}};
177 }
178
179 sub rnodes
180 {
181         my $self = shift;
182         my @out;
183         foreach my $call (@{$self->{nodes}}) {
184                 next if grep $call eq $_, @_;
185                 push @out, $call;
186                 my $r = get($call);
187                 push @out, $r->rnodes($call, @_) if $r;
188         }
189         return @out;
190 }
191
192
193 sub new
194 {
195         my $pkg = shift;
196         my $call = uc shift;
197         
198         confess "already have $call in $pkg" if $list{$call};
199         
200         my $self = $pkg->SUPER::new($call);
201         $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ];
202         $self->{version} = shift;
203         $self->{flags} = shift;
204         $self->{users} = [];
205         $self->{nodes} = [];
206         
207         $list{$call} = $self;
208         
209         return $self;
210 }
211
212 sub get
213 {
214         my $call = shift;
215         $call = shift if ref $call;
216         my $ref = $list{uc $call};
217         dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr');
218         return $ref;
219 }
220
221 sub get_all
222 {
223         return values %list;
224 }
225
226 sub _addparent
227 {
228         my $self = shift;
229     return $self->_addlist('parent', @_);
230 }
231
232 sub _delparent
233 {
234         my $self = shift;
235     return $self->_dellist('parent', @_);
236 }
237
238
239 sub _addnode
240 {
241         my $self = shift;
242     return $self->_addlist('nodes', @_);
243 }
244
245 sub _delnode
246 {
247         my $self = shift;
248     return $self->_dellist('nodes', @_);
249 }
250
251
252 sub _adduser
253 {
254         my $self = shift;
255     return $self->_addlist('users', @_);
256 }
257
258 sub _deluser
259 {
260         my $self = shift;
261     return $self->_dellist('users', @_);
262 }
263
264 sub DESTROY
265 {
266         my $self = shift;
267         my $pkg = ref $self;
268         my $call = $self->{call} || "Unknown";
269         
270         dbg("destroying $pkg with $call") if isdbg('routelow');
271 }
272
273 #
274 # generic AUTOLOAD for accessors
275 #
276
277 sub AUTOLOAD
278 {
279         no strict;
280
281         my $self = shift;
282         $name = $AUTOLOAD;
283         return if $name =~ /::DESTROY$/;
284         $name =~ s/.*:://o;
285   
286         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
287
288         # this clever line of code creates a subroutine which takes over from autoload
289         # from OO Perl - Conway
290 #       print "AUTOLOAD: $AUTOLOAD\n";
291 #       *{$AUTOLOAD} = sub {my $self = shift; @_ ? $self->{$name} = shift : $self->{$name}} ;
292     @_ ? $self->{$name} = shift : $self->{$name} ;
293 }
294
295 1;
296