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