]> scm.dxcluster.org Git - spider.git/blob - perl/Route.pm
added even more colouration in an attempt to make it as clear as possible
[spider.git] / perl / Route.pm
1 #!/usr/bin/perl
2 #
3 # This module impliments the abstracted routing for all protocols and
4 # is probably what I SHOULD have done the first time. 
5 #
6 # Heyho.
7 #
8 # This is just a container class which I expect to subclass 
9 #
10 # Copyright (c) 2001 Dirk Koopman G1TLH
11 #
12 # $Id$
13
14
15 package Route;
16
17 use DXDebug;
18 use DXChannel;
19 use Prefix;
20
21 use strict;
22
23
24 use vars qw($VERSION $BRANCH);
25 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
26 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0;
27 $main::build += $VERSION;
28 $main::branch += $BRANCH;
29
30 use vars qw(%list %valid $filterdef);
31
32 %valid = (
33                   call => "0,Callsign",
34                   flags => "0,Flags,phex",
35                   dxcc => '0,Country Code',
36                   itu => '0,ITU Zone',
37                   cq => '0,CQ Zone',
38                  );
39
40 $filterdef = bless ([
41                           # tag, sort, field, priv, special parser 
42                           ['channel', 'c', 0],
43                           ['channel_dxcc', 'n', 1],
44                           ['channel_itu', 'n', 2],
45                           ['channel_zone', 'n', 3],
46                           ['call', 'c', 4],
47                           ['call_dxcc', 'n', 5],
48                           ['call_itu', 'n', 6],
49                           ['call_zone', 'n', 7],
50                          ], 'Filter::Cmd');
51
52
53 sub new
54 {
55         my ($pkg, $call) = @_;
56         $pkg = ref $pkg if ref $pkg;
57
58         my $self = bless {call => $call}, $pkg;
59         dbg("create $pkg with $call") if isdbg('routelow');
60
61         # add in all the dxcc, itu, zone info
62         my @dxcc = Prefix::extract($call);
63         if (@dxcc > 0) {
64                 $self->{dxcc} = $dxcc[1]->dxcc;
65                 $self->{itu} = $dxcc[1]->itu;
66                 $self->{cq} = $dxcc[1]->cq;                                             
67         }
68         $self->{flags} = here(1);
69         
70         return $self; 
71 }
72
73 #
74 # get a callsign from a passed reference or a string
75 #
76
77 sub _getcall
78 {
79         my $self = shift;
80         my $thingy = shift;
81         $thingy = $self unless $thingy;
82         $thingy = $thingy->call if ref $thingy;
83         $thingy = uc $thingy if $thingy;
84         return $thingy;
85 }
86
87
88 # add and delete a callsign to/from a list
89 #
90
91 sub _addlist
92 {
93         my $self = shift;
94         my $field = shift;
95         foreach my $c (@_) {
96                 my $call = _getcall($c);
97                 unless (grep {$_ eq $call} @{$self->{$field}}) {
98                         push @{$self->{$field}}, $call;
99                         dbg(ref($self) . " adding $call to " . $self->{call} . "->\{$field\}") if isdbg('routelow');
100                 }
101         }
102         return $self->{$field};
103 }
104
105 sub _dellist
106 {
107         my $self = shift;
108         my $field = shift;
109         foreach my $c (@_) {
110                 my $call = _getcall($c);
111                 if (grep {$_ eq $call} @{$self->{$field}}) {
112                         $self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ];
113                         dbg(ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}") if isdbg('routelow');
114                 }
115         }
116         return $self->{$field};
117 }
118
119 #
120 # flag field constructors/enquirers
121 #
122 # These can be called in various ways:-
123 #
124 # Route::here or $ref->here returns 1 or 0 depending on value of the here flag
125 # Route::here(1) returns 2 (the bit value of the here flag)
126 # $ref->here(1) or $ref->here(0) sets the here flag
127 #
128
129 sub here
130 {
131         my $self = shift;
132         my $r = shift;
133         return $self ? 2 : 0 unless ref $self;
134         return ($self->{flags} & 2) ? 1 : 0 unless defined $r;
135         $self->{flags} = (($self->{flags} & ~2) | ($r ? 2 : 0));
136         return $r ? 1 : 0;
137 }
138
139 sub conf
140 {
141         my $self = shift;
142         my $r = shift;
143         return $self ? 1 : 0 unless ref $self;
144         return ($self->{flags} & 1) ? 1 : 0 unless defined $r;
145         $self->{flags} = (($self->{flags} & ~1) | ($r ? 1 : 0));
146         return $r ? 1 : 0;
147 }
148
149 sub parents
150 {
151         my $self = shift;
152         return @{$self->{parent}};
153 }
154
155
156 # display routines
157 #
158
159 sub user_call
160 {
161         my $self = shift;
162         my $call = sprintf "%s", $self->{call};
163         return $self->here ? "$call" : "($call)";
164 }
165
166 sub config
167 {
168         my $self = shift;
169         my $nodes_only = shift;
170         my $level = shift;
171         my $seen = shift;
172         my @out;
173         my $line;
174         my $call = $self->user_call;
175         my $printit = 1;
176
177         # allow ranges
178         if (@_) {
179                 $printit = grep $call =~ m|$_|, @_;
180         }
181
182         if ($printit) {
183                 $line = ' ' x ($level*2) . "$call";
184                 $call = ' ' x length $call; 
185                 
186                 # recursion detector
187                 if ((DXChannel->get($self->{call}) && $level > 1) || grep $self->{call} eq $_, @$seen) {
188                         $line .= ' ...';
189                         push @out, $line;
190                         return @out;
191                 }
192                 push @$seen, $self->{call};
193
194                 # print users
195                 unless ($nodes_only) {
196                         if (@{$self->{users}}) {
197                                 $line .= '->';
198                                 foreach my $ucall (sort @{$self->{users}}) {
199                                         my $uref = Route::User::get($ucall);
200                                         my $c;
201                                         if ($uref) {
202                                                 $c = $uref->user_call;
203                                         } else {
204                                                 $c = "$ucall?";
205                                         }
206                                         if ((length $line) + (length $c) + 1 < 79) {
207                                                 $line .= $c . ' ';
208                                         } else {
209                                                 $line =~ s/\s+$//;
210                                                 push @out, $line;
211                                                 $line = ' ' x ($level*2) . "$call->$c ";
212                                         }
213                                 }
214                         }
215                 }
216                 $line =~ s/->$//g;
217                 $line =~ s/\s+$//;
218                 push @out, $line if length $line;
219         }
220         
221         # deal with more nodes
222         foreach my $ncall (sort @{$self->{nodes}}) {
223                 my $nref = Route::Node::get($ncall);
224
225                 if ($nref) {
226                         my $c = $nref->user_call;
227 #                       dbg("recursing from $call -> $c") if isdbg('routec');
228                         push @out, $nref->config($nodes_only, $level+1, $seen, @_);
229                 } else {
230                         push @out, ' ' x (($level+1)*2)  . "$ncall?" if @_ == 0 || (@_ && grep $ncall =~ m|$_|, @_); 
231                 }
232         }
233
234         return @out;
235 }
236
237 sub cluster
238 {
239         my $nodes = Route::Node::count();
240         my $tot = Route::User::count();
241         my $users = scalar DXCommandmode::get_all();
242         my $maxusers = Route::User::max();
243         my $uptime = main::uptime();
244         
245         return " $nodes nodes, $users local / $tot total users  Max users $maxusers  Uptime $uptime";
246 }
247
248 #
249 # routing things
250 #
251
252 sub get
253 {
254         my $call = shift;
255         return Route::Node::get($call) || Route::User::get($call);
256 }
257
258 # find all the possible dxchannels which this object might be on
259 sub alldxchan
260 {
261         my $self = shift;
262         my @dxchan;
263 #       dbg("Trying node $self->{call}") if isdbg('routech');
264         my $dxchan = DXChannel->get($self->{call});
265         push @dxchan, $dxchan if $dxchan;
266         
267         # it isn't, build up a list of dxchannels and possible ping times 
268         # for all the candidates.
269         unless (@dxchan) {
270                 foreach my $p (@{$self->{parent}}) {
271 #                       dbg("Trying parent $p") if isdbg('routech');
272                         next if $p eq $main::mycall; # the root
273                         my $dxchan = DXChannel->get($p);
274                         if ($dxchan) {
275                                 push @dxchan, $dxchan unless grep $dxchan == $_, @dxchan;
276                         } else {
277                                 next if grep $p eq $_, @_;
278                                 my $ref = Route::Node::get($p);
279 #                               dbg("Next node $p " . ($ref ? 'Found' : 'NOT Found') if isdbg('routech') );
280                                 push @dxchan, $ref->alldxchan($self->{call}, @_) if $ref;
281                         }
282                 }
283         }
284 #       dbg('routech', "Got dxchan: " . join(',', (map{ $_->call } @dxchan)) );
285         return @dxchan;
286 }
287
288 sub dxchan
289 {
290         my $self = shift;
291         my @dxchan = $self->alldxchan;
292         return undef unless @dxchan;
293         
294         # determine the minimum ping channel
295         my $minping = 99999999;
296         my $dxchan;
297         foreach my $dxc (@dxchan) {
298                 my $p = $dxc->pingave;
299                 if (defined $p  && $p < $minping) {
300                         $minping = $p;
301                         $dxchan = $dxc;
302                 }
303         }
304         $dxchan = shift @dxchan unless $dxchan;
305         return $dxchan;
306 }
307
308 #
309 # track destruction
310 #
311
312 sub DESTROY
313 {
314         my $self = shift;
315         my $pkg = ref $self;
316         
317         dbg("$pkg $self->{call} destroyed") if isdbg('routelow');
318 }
319
320 no strict;
321 #
322 # return a list of valid elements 
323
324
325 sub fields
326 {
327         my $pkg = shift;
328         $pkg = ref $pkg if ref $pkg;
329     my $val = "${pkg}::valid";
330         my @out = keys %$val;
331         push @out, keys %valid;
332         return @out;
333 }
334
335 #
336 # return a prompt for a field
337 #
338
339 sub field_prompt
340
341         my ($self, $ele) = @_;
342         my $pkg = ref $self;
343     my $val = "${pkg}::valid";
344         return $val->{$ele} || $valid{$ele};
345 }
346
347 #
348 # generic AUTOLOAD for accessors
349 #
350 sub AUTOLOAD
351 {
352         my $self = shift;
353         my $name = $AUTOLOAD;
354         return if $name =~ /::DESTROY$/;
355         $name =~ s/.*:://o;
356   
357         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
358
359         # this clever line of code creates a subroutine which takes over from autoload
360         # from OO Perl - Conway
361 #       *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
362     @_ ? $self->{$name} = shift : $self->{$name} ;
363 }
364
365 1;