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