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