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