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