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