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 DXUtil;
  20
  21 use Prefix;
  22
  23 use strict;
  24
  25
  26 use vars qw($VERSION $BRANCH);
  27 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /:\s+(\d+)\.(\d+)/ );
  28 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /:\s+\d+\.\d+\.(\d+)\.(\d+)/ || (0,0));
  29 $main::build += $VERSION;
  30 $main::branch += $BRANCH;
  31
  32 use vars qw(%list %valid $filterdef);
  33
  34 %valid = (
  35                   call => "0,Callsign",
  36                   flags => "0,Flags,phex",
  37                   dxcc => '0,Country Code',
  38                   itu => '0,ITU Zone',
  39                   cq => '0,CQ Zone',
  40                   state => '0,State',
  41                   city => '0,City',
  42                   lastseen => '0,Last Seen,atime',
  43                  );
  44
  45 $filterdef = bless ([
  46                           # tag, sort, field, priv, special parser
  47                           ['channel', 'c', 0],
  48                           ['channel_dxcc', 'nc', 1],
  49                           ['channel_itu', 'ni', 2],
  50                           ['channel_zone', 'nz', 3],
  51                           ['call', 'c', 4],
  52                           ['by', 'c', 4],
  53                           ['call_dxcc', 'nc', 5],
  54                           ['by_dxcc', 'nc', 5],
  55                           ['call_itu', 'ni', 6],
  56                           ['by_itu', 'ni', 6],
  57                           ['call_zone', 'nz', 7],
  58                           ['by_zone', 'nz', 7],
  59                           ['channel_state', 'ns', 8],
  60                           ['call_state', 'ns', 9],
  61                           ['by_state', 'ns', 9],
  62                          ], 'Filter::Cmd');
  63
  64
  65 sub new
  66 {
  67         my ($pkg, $call) = @_;
  68         $pkg = ref $pkg if ref $pkg;
  69
  70         my $self = bless {call => $call}, $pkg;
  71         dbg("Create $pkg with $call") if isdbg('routelow');
  72
  73         # add in all the dxcc, itu, zone info
  74         ($self->{dxcc}, $self->{itu}, $self->{cq}, $self->{state}, $self->{city}) =
  75                 Prefix::cty_data($call);
  76
  77         $self->{flags} = here(1);
  78
  79         return $self;
  80 }
  81
  82 #
  83 # get a callsign from a passed reference or a string
  84 #
  85
  86 sub _getcall
  87 {
  88         my $self = shift;
  89         my $thingy = shift;
  90         $thingy = $self unless $thingy;
  91         $thingy = $thingy->call if ref $thingy;
  92         $thingy = uc $thingy if $thingy;
  93         return $thingy;
  94 }
  95
  96 #
  97 # add and delete a callsign to/from a list
  98 #
  99
 100 sub _addlist
 101 {
 102         my $self = shift;
 103         my $field = shift;
 104         my @out;
 105         foreach my $c (@_) {
 106                 confess "Need a ref here" unless ref($c);
 107
 108                 my $call = $c->{call};
 109                 unless (grep $_ eq $call, @{$self->{$field}}) {
 110                         push @{$self->{$field}}, $call;
 111                         dbg(ref($self) . " adding $call to " . $self->{call} . "->\{$field\}") if isdbg('routelow');
 112                         push @out, $c;
 113                 }
 114         }
 115         return @out;
 116 }
 117
 118 sub _dellist
 119 {
 120         my $self = shift;
 121         my $field = shift;
 122         my @out;
 123         foreach my $c (@_) {
 124                 confess "Need a ref here" unless ref($c);
 125                 my $call = $c->{call};
 126                 if (grep $_ eq $call, @{$self->{$field}}) {
 127                         $self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ];
 128                         dbg(ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}") if isdbg('routelow');
 129                         push @out, $c;
 130                 }
 131         }
 132         return @out;
 133 }
 134
 135 sub is_empty
 136 {
 137         my $self = shift;
 138         return @{$self->{$_[0]}} == 0;
 139 }
 140
 141 #
 142 # flag field constructors/enquirers
 143 #
 144 # These can be called in various ways:-
 145 #
 146 # Route::here or $ref->here returns 1 or 0 depending on value of the here flag
 147 # Route::here(1) returns 2 (the bit value of the here flag)
 148 # $ref->here(1) or $ref->here(0) sets the here flag
 149 #
 150
 151 sub here
 152 {
 153         my $self = shift;
 154         my $r = shift;
 155         return $self ? 2 : 0 unless ref $self;
 156         return ($self->{flags} & 2) ? 1 : 0 unless defined $r;
 157         $self->{flags} &= ~2;
 158         $self->{flags} |= $r ? 2 : 0;
 159         return $r ? 1 : 0;
 160 }
 161
 162 sub conf
 163 {
 164         my $self = shift;
 165         my $r = shift;
 166         return $self ? 1 : 0 unless ref $self;
 167         return ($self->{flags} & 1) ? 1 : 0 unless defined $r;
 168         $self->{flags} &= ~1;
 169         $self->{flags} |= $r ? 1 : 0;
 170         return $r ? 1 : 0;
 171 }
 172
 173
 174 sub dec_pc59
 175 {
 176         my $node = shift;
 177         my $s = ref($node) ? shift : $node;
 178         $node = undef;
 179
 180         my ($sort, $here, $callstring) = unpack "A A A*", $s;
 181         my ($call) = $callstring =~ /^([A-Z0-9\-]+)/;
 182         return unless is_callsign($call);
 183         return unless $here =~ /^[0123]$/;
 184         return unless $sort =~ /^[NUE]$/;
 185         if ($sort eq 'E' || $sort eq 'N') {
 186                 $node = Route::Node::get($call) || Route::Node->new($call);
 187                 if ($callstring =~ /b([\d\.])/) {
 188                         $node->{build} = $1;
 189                 }
 190                 if ($callstring =~ /v([\d\.])/) {
 191                         $node->{version} = $1;
 192                 }
 193         } elsif ($sort eq 'U') {
 194                 $node = Route::User::get($call) || Route::User->new($call);
 195         }
 196         $node->{flags} = $here;
 197         $node->{lastseen} = $main::systime;
 198         return $node;
 199 }
 200
 201 #
 202 # display routines
 203 #
 204
 205 sub user_call
 206 {
 207         my $self = shift;
 208         my $call = sprintf "%s", $self->{call};
 209         return $self->here ? "$call" : "($call)";
 210 }
 211
 212 sub config
 213 {
 214         my $self = shift;
 215         my $nodes_only = shift;
 216         my $level = shift;
 217         my $seen = shift;
 218         my @out;
 219         my $line;
 220         my $call = $self->user_call;
 221         my $printit = 1;
 222
 223         # allow ranges
 224         if (@_) {
 225                 $printit = grep $call =~ m|$_|, @_;
 226         }
 227
 228         if ($printit) {
 229                 $line = ' ' x ($level*2) . "$call";
 230                 $call = ' ' x length $call;
 231
 232                 # recursion detector
 233                 if ((DXChannel->get($self->{call}) && $level > 1) || grep $self->{call} eq $_, @$seen) {
 234 #                       $line .= ' ...';
 235 #                       push @out, $line;
 236                         return @out;
 237                 }
 238                 push @$seen, $self->{call};
 239
 240                 # print users
 241                 unless ($nodes_only) {
 242                         if (@{$self->{users}}) {
 243                                 $line .= '->';
 244                                 foreach my $ucall (sort @{$self->{users}}) {
 245                                         my $uref = Route::User::get($ucall);
 246                                         my $c;
 247                                         if ($uref) {
 248                                                 $c = $uref->user_call;
 249                                         } else {
 250                                                 $c = "$ucall?";
 251                                         }
 252                                         if ((length $line) + (length $c) + 1 < 79) {
 253                                                 $line .= $c . ' ';
 254                                         } else {
 255                                                 $line =~ s/\s+$//;
 256                                                 push @out, $line;
 257                                                 $line = ' ' x ($level*2) . "$call->$c ";
 258                                         }
 259                                 }
 260                         }
 261                 }
 262                 $line =~ s/->$//g;
 263                 $line =~ s/\s+$//;
 264                 push @out, $line if length $line;
 265         }
 266
 267         # deal with more nodes
 268         foreach my $ncall (sort @{$self->{nodes}}) {
 269                 my $nref = Route::Node::get($ncall);
 270
 271                 if ($nref) {
 272                         my $c = $nref->user_call;
 273 #                       dbg("recursing from $call -> $c") if isdbg('routec');
 274                         push @out, $nref->config($nodes_only, $level+1, $seen, @_);
 275                 } else {
 276                         push @out, ' ' x (($level+1)*2)  . "$ncall?" if @_ == 0 || (@_ && grep $ncall =~ m|$_|, @_);
 277                 }
 278         }
 279
 280         return @out;
 281 }
 282
 283 sub cluster
 284 {
 285         my $nodes = Route::Node::count();
 286         my $tot = Route::User::count();
 287         my $users = scalar DXCommandmode::get_all();
 288         my $maxusers = Route::User::max();
 289         my $uptime = main::uptime();
 290
 291         return " $nodes nodes, $users local / $tot total users  Max users $maxusers  Uptime $uptime";
 292 }
 293
 294 #
 295 # routing things
 296 #
 297
 298 sub get
 299 {
 300         my $call = shift;
 301         return Route::Node::get($call) || Route::User::get($call);
 302 }
 303
 304 sub get_all
 305 {
 306         return (Route::Node::get_all(), Route::User::get_all());
 307 }
 308
 309 # find all the possible dxchannels which this object might be on
 310 sub alldxchan
 311 {
 312         my $self = shift;
 313
 314         my $dxchan = DXChannel->get($self->{call});
 315         if ($dxchan) {
 316                 dbg("alldxchan for $self->{call} = $dxchan->{call}") if isdbg('routelow');
 317                 return $dxchan if $dxchan;
 318         }
 319
 320         my @nodes;
 321         if ($self->isa('Route::User')) {
 322                 push @nodes, map{Route::Node::get($_)} @{$self->{nodes}};
 323         } elsif ($self->isa('Route::Node')) {
 324                 push @nodes, $self;
 325         }
 326
 327         # it isn't, build up a list of dxchannels and possible ping times
 328         # for all the candidates.
 329         my @dxchan;
 330         foreach my $nref (@nodes) {
 331                 next unless $nref;
 332                 foreach my $p (@{$nref->{dxchan}}) {
 333 #                       dbg("Trying dxchan $p") if isdbg('routech');
 334                         next if $p eq $main::mycall; # the root
 335                         my $dxchan = DXChannel->get($p);
 336                         if ($dxchan) {
 337                                 push @dxchan, $dxchan unless grep $dxchan == $_, @dxchan;
 338                         } else {
 339                                 next if grep $p eq $_, @_;
 340                                 my $ref = Route::Node::get($p);
 341 #                               dbg("Next node $p " . ($ref ? 'Found' : 'NOT Found') if isdbg('routech') );
 342                                 push @dxchan, $ref->alldxchan($self->{call}, @_) if $ref;
 343                         }
 344                 }
 345         }
 346         dbg("alldxchan for $self->{call} = (" . join(',', @dxchan) . ")") if isdbg('routelow');
 347         return @dxchan;
 348 }
 349
 350 sub bestdxchan
 351 {
 352         my $self = shift;
 353
 354         # ALWAYS return the locally connected channel if present;
 355         my $dxchan = DXChannel->get($self->call);
 356         return $dxchan if $dxchan;
 357
 358         my @dxchan = sort { ($a->pingave || 9999999) <=> ($b->pingave || 9999999) } $self->alldxchan;
 359         return undef unless @dxchan;
 360
 361         return shift @dxchan;
 362 }
 363
 364 #
 365 # track destruction
 366 #
 367
 368 sub DESTROY
 369 {
 370         my $self = shift;
 371         my $pkg = ref $self;
 372
 373         dbg("$pkg $self->{call} destroyed") if isdbg('routelow');
 374 }
 375
 376 no strict;
 377 #
 378 # return a list of valid elements
 379 #
 380
 381 sub fields
 382 {
 383         my $pkg = shift;
 384         $pkg = ref $pkg if ref $pkg;
 385     my $val = "${pkg}::valid";
 386         my @out = keys %$val;
 387         push @out, keys %valid;
 388         return @out;
 389 }
 390
 391 #
 392 # return a prompt for a field
 393 #
 394
 395 sub field_prompt
 396 {
 397         my ($self, $ele) = @_;
 398         my $pkg = ref $self;
 399     my $val = "${pkg}::valid";
 400         return $val->{$ele} || $valid{$ele};
 401 }
 402
 403 #
 404 # generic AUTOLOAD for accessors
 405 #
 406 sub AUTOLOAD
 407 {
 408         no strict;
 409         my $name = $AUTOLOAD;
 410         return if $name =~ /::DESTROY$/;
 411         $name =~ s/^.*:://o;
 412
 413         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 414
 415         # this clever line of code creates a subroutine which takes over from autoload
 416         # from OO Perl - Conway
 417         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
 418        goto &$AUTOLOAD;
 419
 420 }
 421
 422 1;