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