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