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