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