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 # pc59 entity encoding and decoding
 175 #
 176 sub enc_pc59
 177 {
 178         my $self = shift;
 179         my $sort = shift || 'N';
 180         my $out = "$sort$self->{flag}$self->{call}";
 181         if ($self->{build}) {
 182                 $out .= "b$self->{build}";
 183         } elsif ($self->{version}) {
 184                 $out .= "v$self->{version}";
 185         }
 186 }
 187
 188 sub dec_pc59
 189 {
 190         my $node = shift;
 191         my $s = ref($node) ? shift : $node;
 192         $node = undef;
 193
 194         my ($sort, $here, $call) = unpack "A A A*", $s;
 195         return unless is_callsign($call);
 196         return unless $here =~ /^[0123]$/;
 197         return unless $sort =~ /^[NUE]$/;
 198         if ($sort eq 'E' || $sort eq 'N') {
 199                 $node = Route::Node::get($call) || Route::Node->new($call);
 200                 if ($s =~ /b([\d\.])/) {
 201                         $node->{build} = $1;
 202                 }
 203                 if ($s =~ /v([\d\.])/) {
 204                         $node->{version} = $1;
 205                 }
 206         } elsif ($sort eq 'U') {
 207                 $node = Route::User::get($call) || Route::User->new($call);
 208         }
 209         $node->{flags} = $here;
 210         $node->{lastseen} = $main::systime;
 211         return $node;
 212 }
 213
 214 #
 215 # display routines
 216 #
 217
 218 sub user_call
 219 {
 220         my $self = shift;
 221         my $call = sprintf "%s", $self->{call};
 222         return $self->here ? "$call" : "($call)";
 223 }
 224
 225 sub config
 226 {
 227         my $self = shift;
 228         my $nodes_only = shift;
 229         my $level = shift;
 230         my $seen = shift;
 231         my @out;
 232         my $line;
 233         my $call = $self->user_call;
 234         my $printit = 1;
 235
 236         # allow ranges
 237         if (@_) {
 238                 $printit = grep $call =~ m|$_|, @_;
 239         }
 240
 241         if ($printit) {
 242                 $line = ' ' x ($level*2) . "$call";
 243                 $call = ' ' x length $call;
 244
 245                 # recursion detector
 246                 if ((DXChannel->get($self->{call}) && $level > 1) || grep $self->{call} eq $_, @$seen) {
 247 #                       $line .= ' ...';
 248 #                       push @out, $line;
 249                         return @out;
 250                 }
 251                 push @$seen, $self->{call};
 252
 253                 # print users
 254                 unless ($nodes_only) {
 255                         if (@{$self->{users}}) {
 256                                 $line .= '->';
 257                                 foreach my $ucall (sort @{$self->{users}}) {
 258                                         my $uref = Route::User::get($ucall);
 259                                         my $c;
 260                                         if ($uref) {
 261                                                 $c = $uref->user_call;
 262                                         } else {
 263                                                 $c = "$ucall?";
 264                                         }
 265                                         if ((length $line) + (length $c) + 1 < 79) {
 266                                                 $line .= $c . ' ';
 267                                         } else {
 268                                                 $line =~ s/\s+$//;
 269                                                 push @out, $line;
 270                                                 $line = ' ' x ($level*2) . "$call->$c ";
 271                                         }
 272                                 }
 273                         }
 274                 }
 275                 $line =~ s/->$//g;
 276                 $line =~ s/\s+$//;
 277                 push @out, $line if length $line;
 278         }
 279
 280         # deal with more nodes
 281         foreach my $ncall (sort @{$self->{nodes}}) {
 282                 my $nref = Route::Node::get($ncall);
 283
 284                 if ($nref) {
 285                         my $c = $nref->user_call;
 286 #                       dbg("recursing from $call -> $c") if isdbg('routec');
 287                         push @out, $nref->config($nodes_only, $level+1, $seen, @_);
 288                 } else {
 289                         push @out, ' ' x (($level+1)*2)  . "$ncall?" if @_ == 0 || (@_ && grep $ncall =~ m|$_|, @_);
 290                 }
 291         }
 292
 293         return @out;
 294 }
 295
 296 sub cluster
 297 {
 298         my $nodes = Route::Node::count();
 299         my $tot = Route::User::count();
 300         my $users = scalar DXCommandmode::get_all();
 301         my $maxusers = Route::User::max();
 302         my $uptime = main::uptime();
 303
 304         return " $nodes nodes, $users local / $tot total users  Max users $maxusers  Uptime $uptime";
 305 }
 306
 307 #
 308 # routing things
 309 #
 310
 311 sub get
 312 {
 313         my $call = shift;
 314         return Route::Node::get($call) || Route::User::get($call);
 315 }
 316
 317 sub get_all
 318 {
 319         return (Route::Node::get_all(), Route::User::get_all());
 320 }
 321
 322 # find all the possible dxchannels which this object might be on
 323 sub alldxchan
 324 {
 325         my $self = shift;
 326
 327         my $dxchan = DXChannel->get($self->{call});
 328         if ($dxchan) {
 329                 dbg("alldxchan for $self->{call} = $dxchan->{call}") if isdbg('routelow');
 330                 return $dxchan if $dxchan;
 331         }
 332
 333         my @nodes;
 334         if ($self->isa('Route::User')) {
 335                 push @nodes, map{Route::Node::get($_)} @{$self->{nodes}};
 336         } elsif ($self->isa('Route::Node')) {
 337                 push @nodes, $self;
 338         }
 339
 340         # it isn't, build up a list of dxchannels and possible ping times
 341         # for all the candidates.
 342         my @dxchan;
 343         foreach my $nref (@nodes) {
 344                 next unless $nref;
 345                 foreach my $p (@{$nref->{dxchan}}) {
 346 #                       dbg("Trying dxchan $p") if isdbg('routech');
 347                         next if $p eq $main::mycall; # the root
 348                         my $dxchan = DXChannel->get($p);
 349                         if ($dxchan) {
 350                                 push @dxchan, $dxchan unless grep $dxchan == $_, @dxchan;
 351                         } else {
 352                                 next if grep $p eq $_, @_;
 353                                 my $ref = Route::Node::get($p);
 354 #                               dbg("Next node $p " . ($ref ? 'Found' : 'NOT Found') if isdbg('routech') );
 355                                 push @dxchan, $ref->alldxchan($self->{call}, @_) if $ref;
 356                         }
 357                 }
 358         }
 359         dbg("alldxchan for $self->{call} = (" . join(',', @dxchan) . ")") if isdbg('routelow');
 360         return @dxchan;
 361 }
 362
 363 sub bestdxchan
 364 {
 365         my $self = shift;
 366
 367         # ALWAYS return the locally connected channel if present;
 368         my $dxchan = DXChannel->get($self->call);
 369         return $dxchan if $dxchan;
 370
 371         my @dxchan = sort { ($a->pingave || 9999999) <=> ($b->pingave || 9999999) } $self->alldxchan;
 372         return undef unless @dxchan;
 373
 374         return shift @dxchan;
 375 }
 376
 377 #
 378 # track destruction
 379 #
 380
 381 sub DESTROY
 382 {
 383         my $self = shift;
 384         my $pkg = ref $self;
 385
 386         dbg("$pkg $self->{call} destroyed") if isdbg('routelow');
 387 }
 388
 389 no strict;
 390 #
 391 # return a list of valid elements
 392 #
 393
 394 sub fields
 395 {
 396         my $pkg = shift;
 397         $pkg = ref $pkg if ref $pkg;
 398     my $val = "${pkg}::valid";
 399         my @out = keys %$val;
 400         push @out, keys %valid;
 401         return @out;
 402 }
 403
 404 #
 405 # return a prompt for a field
 406 #
 407
 408 sub field_prompt
 409 {
 410         my ($self, $ele) = @_;
 411         my $pkg = ref $self;
 412     my $val = "${pkg}::valid";
 413         return $val->{$ele} || $valid{$ele};
 414 }
 415
 416 #
 417 # generic AUTOLOAD for accessors
 418 #
 419 sub AUTOLOAD
 420 {
 421         no strict;
 422         my $name = $AUTOLOAD;
 423         return if $name =~ /::DESTROY$/;
 424         $name =~ s/^.*:://o;
 425
 426         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 427
 428         # this clever line of code creates a subroutine which takes over from autoload
 429         # from OO Perl - Conway
 430         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
 431        goto &$AUTOLOAD;
 432
 433 }
 434
 435 1;