perl/Prefix.pm

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