perl/Prefix.pm

   1 #
   2 # prefix handling
   3 #
   4 # Copyright (c) - Dirk Koopman G1TLH
   5 #
   6 # $Id$
   7 #
   8
   9 package Prefix;
  10
  11 use IO::File;
  12 use DXVars;
  13 use DB_File;
  14 use Data::Dumper;
  15 use DXDebug;
  16 use DXUtil;
  17 use USDB;
  18 use LRU;
  19
  20 use strict;
  21
  22 use vars qw($VERSION $BRANCH);
  23 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  24 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  25 $main::build += $VERSION;
  26 $main::branch += $BRANCH;
  27
  28 use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal);
  29
  30 $db = undef;                                    # the DB_File handle
  31 %prefix_loc = ();                               # the meat of the info
  32 %pre = ();                                              # the prefix list
  33 $hits = $misses = $matchtotal = 1;              # cache stats
  34 $lrusize = 1000;                                # size of prefix LRU cache
  35
  36 sub init
  37 {
  38         my $r = load();
  39         return $r if $r;
  40
  41         # fix up the node's default country codes
  42         unless (@main::my_cc) {
  43                 push @main::my_cc, (61..67) if $main::mycall =~ /^GB/;
  44                 push @main::my_cc, qw(EA EA6 EA8 EA9) if $main::mycall =~ /^E[ABCD]/;
  45                 push @main::my_cc, qw(I IT IS) if $main::mycall =~ /^I/;
  46                 push @main::my_cc, qw(SV SV5 SV9) if $main::mycall =~ /^SV/;
  47
  48                 # catchall
  49                 push @main::my_cc, $main::mycall unless @main::my_cc;
  50         }
  51
  52         my @c;
  53         for (@main::my_cc) {
  54                 if (/^\d+$/) {
  55                         push @c, $_;
  56                 } else {
  57                         my @dxcc = extract($_);
  58                         push @c, $dxcc[1]->dxcc if @dxcc > 1;
  59                 }
  60         }
  61         return "\@main::my_cc does not contain a valid prefix or callsign (" . join(',', @main::my_cc) . ")" unless @c;
  62         @main::my_cc = @c;
  63         return undef;
  64 }
  65
  66 sub load
  67 {
  68         # untie every thing
  69         if ($db) {
  70                 undef $db;
  71                 untie %pre;
  72                 %pre = ();
  73                 %prefix_loc = ();
  74                 $lru->close if $lru;
  75                 undef $lru;
  76         }
  77
  78         # tie the main prefix database
  79         eval {$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE);};
  80         my $out = "$@($!)" if !$db || $@ ;
  81         eval {do "$main::data/prefix_data.pl" if !$out; };
  82         $out .= $@ if $@;
  83         $lru = LRU->newbase('Prefix', $lrusize);
  84
  85         return $out;
  86 }
  87
  88 sub loaded
  89 {
  90         return $db;
  91 }
  92
  93 sub store
  94 {
  95         my ($k, $l);
  96         my $fh = new IO::File;
  97         my $fn = "$main::data/prefix_data.pl";
  98
  99         confess "Prefix system not started" if !$db;
 100
 101         # save versions!
 102         rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
 103         rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
 104         rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
 105         rename "$fn.o", "$fn.oo" if -e "$fn.o";
 106         rename "$fn", "$fn.o" if -e "$fn";
 107
 108         $fh->open(">$fn") or die "Can't open $fn ($!)";
 109
 110         # prefix location data
 111         $fh->print("%prefix_loc = (\n");
 112         foreach $l (sort {$a <=> $b} keys %prefix_loc) {
 113                 my $r = $prefix_loc{$l};
 114                 $fh->printf("   $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
 115                                         $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
 116         }
 117         $fh->print(");\n\n");
 118
 119         # prefix data
 120         $fh->print("%pre = (\n");
 121         foreach $k (sort keys %pre) {
 122                 $fh->print("   '$k' => [");
 123                 my @list = @{$pre{$k}};
 124                 my $l;
 125                 my $str;
 126                 foreach $l (@list) {
 127                         $str .= " $l,";
 128                 }
 129                 chop $str;
 130                 $fh->print("$str ],\n");
 131         }
 132         $fh->print(");\n");
 133         undef $fh;
 134         untie %pre;
 135 }
 136
 137 # what you get is a list that looks like:-
 138 #
 139 # prefix => @list of blessed references to prefix_locs
 140 #
 141 # This routine will only do what you ask for, if you wish to be intelligent
 142 # then that is YOUR problem!
 143 #
 144
 145 sub get
 146 {
 147         my $key = shift;
 148         my $ref;
 149         my $gotkey = $key;
 150         return () if $db->seq($gotkey, $ref, R_CURSOR);
 151         return () if $key ne substr $gotkey, 0, length $key;
 152
 153         return ($gotkey,  map { $prefix_loc{$_} } split ',', $ref);
 154 }
 155
 156 #
 157 # get the next key that matches, this assumes that you have done a 'get' first
 158 #
 159 #
 160 sub next
 161 {
 162         my $key = shift;
 163         my $ref;
 164         my $gotkey;
 165
 166         return () if $db->seq($gotkey, $ref, R_NEXT);
 167         return () if $key ne substr $gotkey, 0, length $key;
 168
 169         return ($gotkey,  map { $prefix_loc{$_} } split ',', $ref);
 170 }
 171
 172 #
 173 # put the key LRU incluing the city state info
 174 #
 175
 176 sub lru_put
 177 {
 178         my ($call, $ref) = @_;
 179         my @s = USDB::get($call);
 180
 181         if (@s) {
 182                 # this is deep magic, because this is a reference to static data, it
 183         # must be copied.
 184                 my $h = { %{$ref->[1]} };
 185                 bless $h, ref $ref->[1];
 186                 $h->{city} = $s[0];
 187                 $h->{state} = $s[1];
 188                 $ref->[1] = $h;
 189         } else {
 190                 $ref->[1]->{city} = $ref->[1]->{state} = "" unless exists $ref->[1]->{state};
 191         }
 192
 193         dbg("Prefix::lru_put $call -> ($ref->[1]->{city}, $ref->[1]->{state})") if isdbg('prefix');
 194         $lru->put($call, $ref);
 195 }
 196
 197 #
 198 # search for the nearest match of a prefix string (starting
 199 # from the RH end of the string passed)
 200 #
 201
 202 sub matchprefix
 203 {
 204         my $pref = shift;
 205         my @partials;
 206
 207         for (my $i = length $pref; $i; $i--) {
 208                 $matchtotal++;
 209                 my $s = substr($pref, 0, $i);
 210                 push @partials, $s;
 211                 my $p = $lru->get($s);
 212                 if ($p) {
 213                         $hits++;
 214                         if (isdbg('prefix')) {
 215                                 my $percent = sprintf "%.1f", $hits * 100 / $misses;
 216                                 dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%");
 217                         }
 218                         lru_put($_, $p) for @partials;
 219                         return @$p;
 220                 } else {
 221                         $misses++;
 222                         my @out = get($s);
 223                         if (isdbg('prefix')) {
 224                                 my $part = $out[0] || "*";
 225                                 $part .= '*' unless $part eq '*' || $part eq $s;
 226                                 dbg("Partial prefix: $pref $s $part" );
 227                         }
 228                         if (@out && $out[0] eq $s) {
 229                                 return @out;
 230                         }
 231                 }
 232         }
 233         return ();
 234 }
 235
 236 #
 237 # extract a 'prefix' from a callsign, in other words the largest entity that will
 238 # obtain a result from the prefix table.
 239 #
 240 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
 241 # G1TLH/VO1 (should) return VO1
 242 #
 243
 244 sub extract
 245 {
 246         my $calls = uc shift;
 247         my @out;
 248         my $p;
 249         my @parts;
 250         my ($call, $sp, $i);
 251
 252 LM:     foreach $call (split /,/, $calls) {
 253
 254                 # first check if the whole thing succeeds either because it is cached
 255                 # or because it simply is a stored prefix as callsign (or even a prefix)
 256                 $matchtotal++;
 257                 $call =~ s/-\d+$//;             # ignore SSIDs
 258                 my $p = $lru->get($call);
 259                 my @nout;
 260                 if ($p) {
 261                         $hits++;
 262                         if (isdbg('prefix')) {
 263                                 my $percent = sprintf "%.1f", $hits * 100 / $misses;
 264                                 dbg("Prefix Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
 265                         }
 266                         push @out, @$p;
 267                         next;
 268                 } else {
 269
 270                         # is it in the USDB, force a matchprefix to match?
 271                         my @s = USDB::get($call);
 272                         if (@s) {
 273                                 @nout = get($call);
 274                                 @nout = matchprefix($call) unless @nout;
 275                                 $nout[0] = $call if @nout;
 276                         } else {
 277                                 @nout =  get($call);
 278                         }
 279
 280                         # now store it
 281                         if (@nout && $nout[0] eq $call) {
 282                                 $misses++;
 283                                 lru_put($call, \@nout);
 284                                 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
 285                                 push @out, @nout;
 286                                 next;
 287                         }
 288                 }
 289
 290                 # now split the call into parts if required
 291                 @parts = ($call =~ '/') ? split('/', $call) : ($call);
 292                 dbg("Parts: $call = " . join(' ', @parts))      if isdbg('prefix');
 293
 294                 # remove any /0-9 /P /A /M /MM /AM suffixes etc
 295                 if (@parts > 1) {
 296                         @parts = grep { !/^\d+$/ && !/^[PABM]$/ && !/^(?:|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/; } @parts;
 297
 298                         # can we resolve them by direct lookup
 299                         my $s = join('/', @parts);
 300                         @nout = get($s);
 301                         if (@nout && $nout[0] eq $s) {
 302                                 dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
 303                                 $misses++;
 304                                 lru_put($call, \@nout);
 305                                 push @out, @nout;
 306                                 next;
 307                         }
 308                 }
 309                 dbg("Parts now: $call = " . join(' ', @parts))  if isdbg('prefix');
 310
 311                 # at this point we should have two or three parts
 312                 # if it is three parts then join the first and last parts together
 313                 # to get an answer
 314
 315                 # first deal with prefix/x00xx/single letter things
 316                 if (@parts == 3 && length $parts[0] <= length $parts[1]) {
 317                         @nout = matchprefix($parts[0]);
 318                         if (@nout) {
 319                                 my $s = join('/', $nout[0], $parts[2]);
 320                                 my @try = get($s);
 321                                 if (@try && $try[0] eq $s) {
 322                                         dbg("got 3 part prefix: $call $s") if isdbg('prefix');
 323                                         $misses++;
 324                                         lru_put($call, \@try);
 325                                         push @out, @try;
 326                                         next;
 327                                 }
 328
 329                                 # if the second part is a callsign and the last part is one letter
 330                                 if (is_callsign($parts[1]) && length $parts[2] == 1) {
 331                                         pop @parts;
 332                                 }
 333                         }
 334                 }
 335
 336                 # if it is a two parter
 337                 if (@parts == 2) {
 338
 339                         # try it as it is as compound, taking the first part as the prefix
 340                         @nout = matchprefix($parts[0]);
 341                         if (@nout) {
 342                                 my $s = join('/', $nout[0], $parts[1]);
 343                                 my @try = get($s);
 344                                 if (@try && $try[0] eq $s) {
 345                                         dbg("got 2 part prefix: $call $s") if isdbg('prefix');
 346                                         $misses++;
 347                                         lru_put($call, \@try);
 348                                         push @out, @try;
 349                                         next;
 350                                 }
 351                         }
 352                 }
 353
 354                 # remove the problematic /J suffix
 355                 pop @parts if @parts > 1 && $parts[$#parts] eq 'J';
 356
 357                 # single parter
 358                 if (@parts == 1) {
 359                         @nout = matchprefix($parts[0]);
 360                         if (@nout) {
 361                                 dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
 362                                 $misses++;
 363                                 lru_put($call, \@nout);
 364                                 push @out, @nout;
 365                                 next;
 366                         }
 367                 }
 368
 369                 # try ALL the parts
 370         my @checked;
 371                 my $n;
 372 L1:             for ($n = 0; $n < @parts; $n++) {
 373                         my $sp = '';
 374                         my ($k, $i);
 375                         for ($i = $k = 0; $i < @parts; $i++) {
 376                                 next if $checked[$i];
 377                                 my $p = $parts[$i];
 378                                 if (!$sp || length $p < length $sp) {
 379                                         dbg("try part: $p") if isdbg('prefix');
 380                                         $k = $i;
 381                                         $sp = $p;
 382                                 }
 383                         }
 384                         $checked[$k] = 1;
 385                         $sp =~ s/-\d+$//;     # remove any SSID
 386
 387                         # now start to resolve it from the right hand end
 388                         @nout = matchprefix($sp);
 389
 390                         # try and search for it in the descriptions as
 391                         # a whole callsign if it has multiple parts and the output
 392                         # is more two long, this should catch things like
 393                         # FR5DX/T without having to explicitly stick it into
 394                         # the prefix table.
 395
 396                         if (@nout) {
 397                                 if (@parts > 1) {
 398                                         $parts[$k] = $nout[0];
 399                                         my $try = join('/', @parts);
 400                                         my @try = get($try);
 401                                         if (isdbg('prefix')) {
 402                                                 my $part = $try[0] || "*";
 403                                                 $part .= '*' unless $part eq '*' || $part eq $try;
 404                                                 dbg("Compound prefix: $try $part" );
 405                                         }
 406                                         if (@try && $try eq $try[0]) {
 407                                                 $misses++;
 408                                                 lru_put($call, \@try);
 409                                                 push @out, @try;
 410                                         } else {
 411                                                 $misses++;
 412                                                 lru_put($call, \@nout);
 413                                                 push @out, @nout;
 414                                         }
 415                                 } else {
 416                                         $misses++;
 417                                         lru_put($call, \@nout);
 418                                         push @out, @nout;
 419                                 }
 420                                 next LM;
 421                         }
 422                 }
 423
 424                 # we are a pirate!
 425                 @nout = matchprefix('Q');
 426                 $misses++;
 427                 lru_put($call, \@nout);
 428                 push @out, @nout;
 429         }
 430
 431         if (isdbg('prefixdata')) {
 432                 my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
 433                 dbg($dd->Dumpxs);
 434         }
 435         return @out;
 436 }
 437
 438 #
 439 # turn a list of prefixes / dxcc numbers into a list of dxcc/itu/zone numbers
 440 #
 441 # nc = dxcc
 442 # ni = itu
 443 # nz = zone
 444 # ns = state
 445 #
 446
 447 sub to_ciz
 448 {
 449         my $cmd = shift;
 450         my @out;
 451
 452         foreach my $v (@_) {
 453                 if ($cmd ne 'ns' && $v =~ /^\d+$/) {
 454                         push @out, $v unless grep $_ eq $v, @out;
 455                 } else {
 456                         if ($cmd eq 'ns' && $v =~ /^[A-Z][A-Z]$/i) {
 457                                 push @out, uc $v unless grep $_ eq uc $v, @out;
 458                         } else {
 459                                 my @pre = Prefix::extract($v);
 460                                 if (@pre) {
 461                                         shift @pre;
 462                                         foreach my $p (@pre) {
 463                                                 my $n = $p->dxcc if $cmd eq 'nc' ;
 464                                                 $n = $p->itu if $cmd eq 'ni' ;
 465                                                 $n = $p->cq if $cmd eq 'nz' ;
 466                                                 $n = $p->state if $cmd eq 'ns';
 467                                                 push @out, $n unless grep $_ eq $n, @out;
 468                                         }
 469                                 }
 470                         }
 471                 }
 472         }
 473         return @out;
 474 }
 475
 476 # get the full country data (dxcc, itu, cq, state, city) as a list
 477 # from a callsign.
 478 sub cty_data
 479 {
 480         my $call = shift;
 481
 482         my @dxcc = extract($call);
 483         if (@dxcc) {
 484                 my $state = $dxcc[1]->state || '';
 485                 my $city = $dxcc[1]->city || '';
 486                 my $name = $dxcc[1]->name || '';
 487
 488                 return ($dxcc[1]->dxcc, $dxcc[1]->itu, $dxcc[1]->cq, $state, $city, $name);
 489         }
 490         return (666,0,0,'','','Pirate-Country-QQ');
 491 }
 492
 493 my %valid = (
 494                          lat => '0,Latitude,slat',
 495                          long => '0,Longitude,slong',
 496                          dxcc => '0,DXCC',
 497                          name => '0,Name',
 498                          itu => '0,ITU',
 499                          cq => '0,CQ',
 500                          state => '0,State',
 501                          city => '0,City',
 502                          utcoff => '0,UTC offset',
 503                          cont => '0,Continent',
 504                         );
 505
 506 sub AUTOLOAD
 507 {
 508         no strict;
 509         my $name = $AUTOLOAD;
 510
 511         return if $name =~ /::DESTROY$/;
 512         $name =~ s/^.*:://o;
 513
 514         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 515         # this clever line of code creates a subroutine which takes over from autoload
 516         # from OO Perl - Conway
 517         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 518        goto &$AUTOLOAD;
 519 }
 520
 521 #
 522 # return a prompt for a field
 523 #
 524
 525 sub field_prompt
 526 {
 527         my ($self, $ele) = @_;
 528         return $valid{$ele};
 529 }
 530 1;
 531
 532 __END__