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