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                 push @partials, $s;
 155                 my $p = $cache{$s};
 156                 if ($p) {
 157                         $hits++;
 158                         if (isdbg('prefix')) {
 159                                 my $percent = sprintf "%.1f", $hits * 100 / $misses;
 160                                 dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%");
 161                         }
 162                         $cache{$_} = $p for @partials;
 163                         return @$p;
 164                 } else {
 165                         $misses++;
 166                         my @out = get($s);
 167                         if (isdbg('prefix')) {
 168                                 my $part = $out[0] || "*";
 169                                 $part .= '*' unless $part eq '*' || $part eq $s;
 170                                 dbg("Partial prefix: $pref $s $part" );
 171                         }
 172                         if (@out && $out[0] eq $s) {
 173                                 $cache{$_} =  \@out for @partials;
 174                                 return @out;
 175                         }
 176                 }
 177         }
 178         return ();
 179 }
 180
 181 #
 182 # extract a 'prefix' from a callsign, in other words the largest entity that will
 183 # obtain a result from the prefix table.
 184 #
 185 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
 186 # G1TLH/VO1 (should) return VO1
 187 #
 188
 189 sub extract
 190 {
 191         my $calls = uc shift;
 192         my @out;
 193         my $p;
 194         my @parts;
 195         my ($call, $sp, $i);
 196
 197         # clear out the cache periodically to stop it growing for ever.
 198         if ($main::systime - $lasttime >= 20*60) {
 199                 if (isdbg('prefix')) {
 200                         my $percent = sprintf "%.1f", $hits * 100 / $misses;
 201                         dbg("Prefix Cache Cleared, Hits: $hits/$misses of $matchtotal = $percent\%") ;
 202                 }
 203                 %cache =();
 204                 $lasttime = $main::systime;
 205                 $hits = $matchtotal = 0;
 206         }
 207
 208 LM:     foreach $call (split /,/, $calls) {
 209
 210                 # first check if the whole thing succeeds either because it is cached
 211                 # or because it simply is a stored prefix as callsign (or even a prefix)
 212                 $matchtotal++;
 213                 my $p = $cache{$call};
 214                 my @nout;
 215                 if ($p) {
 216                         $hits++;
 217                         if (isdbg('prefix')) {
 218                                 my $percent = sprintf "%.1f", $hits * 100 / $misses;
 219                                 dbg("Prefix Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
 220                         }
 221                         push @out, @$p;
 222                         next;
 223                 } else {
 224                         @nout =  get($call);
 225                         if (@nout && $nout[0] eq $call) {
 226                                 $misses++;
 227                                 $cache{$call} = \@nout;
 228                                 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
 229                                 push @out, @nout;
 230                                 next;
 231                         }
 232                 }
 233
 234                 # now split the call into parts if required
 235                 @parts = ($call =~ '/') ? split('/', $call) : ($call);
 236                 dbg("Parts: $call = " . join(' ', @parts))      if isdbg('prefix');
 237
 238                 # remove any /0-9 /P /A /M /MM /AM suffixes etc
 239                 if (@parts > 1) {
 240                         @parts = grep { !/^\d+$/ && !/^[PABM]$/ && !/^(?:|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/; } @parts;
 241
 242                         # can we resolve them by direct lookup
 243                         my $s = join('/', @parts);
 244                         @nout = get($s);
 245                         if (@nout && $nout[0] eq $s) {
 246                                 dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
 247                                 $misses++;
 248                                 $cache{$call} = \@nout;
 249                                 push @out, @nout;
 250                                 next;
 251                         }
 252                 }
 253                 dbg("Parts now: $call = " . join(' ', @parts))  if isdbg('prefix');
 254
 255                 # at this point we should have two or three parts
 256                 # if it is three parts then join the first and last parts together
 257                 # to get an answer
 258
 259                 # first deal with prefix/x00xx/single letter things
 260                 if (@parts == 3 && length $parts[0] <= length $parts[1]) {
 261                         @nout = matchprefix($parts[0]);
 262                         if (@nout) {
 263                                 my $s = join('/', $nout[0], $parts[2]);
 264                                 my @try = get($s);
 265                                 if (@try && $try[0] eq $s) {
 266                                         dbg("got 3 part prefix: $call $s") if isdbg('prefix');
 267                                         $misses++;
 268                                         $cache{$call} = \@try;
 269                                         push @out, @try;
 270                                         next;
 271                                 }
 272
 273                                 # if the second part is a callsign and the last part is one letter
 274                                 if (is_callsign($parts[1]) && length $parts[2] == 1) {
 275                                         pop @parts;
 276                                 }
 277                         }
 278                 }
 279
 280                 # if it is a two parter
 281                 if (@parts == 2) {
 282
 283                         # try it as it is as compound, taking the first part as the prefix
 284                         @nout = matchprefix($parts[0]);
 285                         if (@nout) {
 286                                 my $s = join('/', $nout[0], $parts[1]);
 287                                 my @try = get($s);
 288                                 if (@try && $try[0] eq $s) {
 289                                         dbg("got 2 part prefix: $call $s") if isdbg('prefix');
 290                                         $misses++;
 291                                         $cache{$call} = \@try;
 292                                         push @out, @try;
 293                                         next;
 294                                 }
 295                         }
 296                 }
 297
 298                 # remove the problematic /J suffix
 299                 pop @parts if @parts > 1 && $parts[$#parts] eq 'J';
 300
 301                 # single parter
 302                 if (@parts == 1) {
 303                         @nout = matchprefix($parts[0]);
 304                         if (@nout) {
 305                                 dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
 306                                 $misses++;
 307                                 $cache{$call} = \@nout;
 308                                 push @out, @nout;
 309                                 next;
 310                         }
 311                 }
 312
 313                 # try ALL the parts
 314         my @checked;
 315                 my $n;
 316 L1:             for ($n = 0; $n < @parts; $n++) {
 317                         my $sp = '';
 318                         my ($k, $i);
 319                         for ($i = $k = 0; $i < @parts; $i++) {
 320                                 next if $checked[$i];
 321                                 my $p = $parts[$i];
 322                                 if (!$sp || length $p < length $sp) {
 323                                         dbg("try part: $p") if isdbg('prefix');
 324                                         $k = $i;
 325                                         $sp = $p;
 326                                 }
 327                         }
 328                         $checked[$k] = 1;
 329                         $sp =~ s/-\d+$//;     # remove any SSID
 330
 331                         # now start to resolve it from the right hand end
 332                         @nout = matchprefix($sp);
 333
 334                         # try and search for it in the descriptions as
 335                         # a whole callsign if it has multiple parts and the output
 336                         # is more two long, this should catch things like
 337                         # FR5DX/T without having to explicitly stick it into
 338                         # the prefix table.
 339
 340                         if (@nout) {
 341                                 if (@parts > 1) {
 342                                         $parts[$k] = $nout[0];
 343                                         my $try = join('/', @parts);
 344                                         my @try = get($try);
 345                                         if (isdbg('prefix')) {
 346                                                 my $part = $try[0] || "*";
 347                                                 $part .= '*' unless $part eq '*' || $part eq $try;
 348                                                 dbg("Compound prefix: $try $part" );
 349                                         }
 350                                         if (@try && $try eq $try[0]) {
 351                                                 $misses++;
 352                                                 $cache{$call} = \@try;
 353                                                 push @out, @try;
 354                                         } else {
 355                                                 $misses++;
 356                                                 $cache{$call} = \@nout;
 357                                                 push @out, @nout;
 358                                         }
 359                                 } else {
 360                                         $misses++;
 361                                         $cache{$call} = \@nout;
 362                                         push @out, @nout;
 363                                 }
 364                                 next LM;
 365                         }
 366                 }
 367
 368                 # we are a pirate!
 369                 @nout = matchprefix('Q');
 370                 $misses++;
 371                 $cache{$call} = \@nout;
 372                 push @out, @nout;
 373         }
 374
 375         if (isdbg('prefixdata')) {
 376                 my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
 377                 dbg($dd->Dumpxs);
 378         }
 379         return @out;
 380 }
 381
 382 my %valid = (
 383                          lat => '0,Latitude,slat',
 384                          long => '0,Longitude,slong',
 385                          dxcc => '0,DXCC',
 386                          name => '0,Name',
 387                          itu => '0,ITU',
 388                          cq => '0,CQ',
 389                          utcoff => '0,UTC offset',
 390                          cont => '0,Continent',
 391                         );
 392
 393 no strict;
 394 sub AUTOLOAD
 395 {
 396         my $self = shift;
 397         my $name = $AUTOLOAD;
 398
 399         return if $name =~ /::DESTROY$/;
 400         $name =~ s/.*:://o;
 401
 402         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 403         # this clever line of code creates a subroutine which takes over from autoload
 404         # from OO Perl - Conway
 405         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 406         if (@_) {
 407                 $self->{$name} = shift;
 408         }
 409         return $self->{$name};
 410 }
 411 use strict;
 412
 413 #
 414 # return a prompt for a field
 415 #
 416
 417 sub field_prompt
 418 {
 419         my ($self, $ele) = @_;
 420         return $valid{$ele};
 421 }
 422 1;
 423
 424 __END__