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 Carp;
  12 use DXVars;
  13 use DB_File;
  14 use Data::Dumper;
  15 use Carp;
  16
  17 use strict;
  18 use vars qw($db  %prefix_loc %pre);
  19
  20 $db;     # the DB_File handle
  21 %prefix_loc;   # the meat of the info
  22 %pre;       # the prefix list
  23
  24 sub load
  25 {
  26   if ($db) {
  27     untie %pre;
  28         %pre = ();
  29         %prefix_loc = ();
  30   }
  31   $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE) or confess "can't tie \%pre ($!)";
  32   confess $@ if $@;
  33   do "$main::data/prefix_data.pl";
  34 #  print Data::Dumper->Dump([\%pre, \%prefix_loc], [qw(pre prefix_loc)]);
  35 }
  36
  37 sub store
  38 {
  39   my ($k, $l);
  40   my $fh = new FileHandle;
  41   my $fn = "$main::data/prefix_data.pl";
  42
  43   confess "Prefix system not started" if !$db;
  44
  45   # save versions!
  46   rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
  47   rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
  48   rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
  49   rename "$fn.o", "$fn.oo" if -e "$fn.o";
  50   rename "$fn", "$fn.o" if -e "$fn";
  51
  52   $fh->open(">$fn") or die "Can't open $fn ($!)";
  53
  54   # prefix location data
  55   $fh->print("%prefix_loc = (\n");
  56   foreach $l (sort {$a <=> $b} keys %prefix_loc) {
  57     my $r = $prefix_loc{$l};
  58         $fh->printf("   $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
  59                     $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
  60   }
  61   $fh->print(");\n\n");
  62
  63   # prefix data
  64   $fh->print("%pre = (\n");
  65   foreach $k (sort keys %pre) {
  66     $fh->print("   '$k' => [");
  67         my @list = @{$pre{$k}};
  68         my $l;
  69         my $str;
  70         foreach $l (@list) {
  71       $str .= " $l,";
  72     }
  73         chop $str;
  74         $fh->print("$str ],\n");
  75   }
  76   $fh->print(");\n");
  77   $fh->close;
  78 }
  79
  80 # what you get is a list that looks like:-
  81 #
  82 # prefix => @list of blessed references to prefix_locs
  83 #
  84 # This routine will only do what you ask for, if you wish to be intelligent
  85 # then that is YOUR problem!
  86 #
  87 sub get
  88 {
  89   my $key = shift;
  90   my @out;
  91   my @outref;
  92   my $ref;
  93   my $gotkey;
  94
  95   $gotkey = $key;
  96   return () if $db->seq($gotkey, $ref, R_CURSOR);
  97   return () if $key ne substr $gotkey, 0, length $key;
  98
  99   @outref = map { $prefix_loc{$_} } split ',', $ref;
 100   return ($gotkey, @outref);
 101 }
 102
 103 #
 104 # get the next key that matches, this assumes that you have done a 'get' first
 105 #
 106 #
 107 sub next
 108 {
 109   my $key = shift;
 110   my @out;
 111   my @outref;
 112   my $ref;
 113   my $gotkey;
 114
 115   return () if $db->seq($gotkey, $ref, R_NEXT);
 116   return () if $key ne substr $gotkey, 0, length $key;
 117
 118   @outref = map { $prefix_loc{$_} } split ',', $ref;
 119   return ($gotkey, @outref);
 120 }
 121
 122 #
 123 # extract a 'prefix' from a callsign, in other words the largest entity that will
 124 # obtain a result from the prefix table.
 125 #
 126 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
 127 # G1TLH/VO1 (should) return VO1
 128 #
 129
 130 sub extract
 131 {
 132   my $call = uc shift;
 133   my @out;
 134   my @nout;
 135   my $p;
 136   my @parts;
 137   my ($sp, $i);
 138
 139   # first check if the whole thing succeeds
 140   @out = get($call);
 141   return @out if @out > 0 && $out[0] eq $call;
 142
 143   # now split the call into parts if required
 144   @parts = ($call =~ '/') ? split('/', $call) : ($call);
 145
 146   # remove any /0-9 /P /A /M /MM /AM suffixes etc
 147   if (@parts > 1) {
 148     $p = $parts[$#parts];
 149         pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o;
 150     $p = $parts[$#parts];
 151         pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o;
 152
 153     # can we resolve them by direct lookup
 154         foreach $p (@parts) {
 155       @out = get($p);
 156           return @out if @out > 0 && $out[0] eq $call;
 157         }
 158   }
 159
 160   # which is the shortest part (first if equal)?
 161   $sp = $parts[0];
 162   foreach $p (@parts) {
 163     $sp = $p if length $sp > length $p;
 164   }
 165   # now start to resolve it from the left hand end
 166   for (@out = (), $i = 1; $i <= length $sp; ++$i) {
 167     @nout = get(substr($sp, 0, $i));
 168         last if @nout > 0 && $nout[0] gt $sp;
 169         last if @nout == 0;
 170         @out = @nout;
 171   }
 172
 173   # not found
 174   return (@out > 0) ? @out : ();
 175 }
 176
 177 my %valid = (
 178   lat => '0,Latitude,slat',
 179   long => '0,Longitude,slong',
 180   dxcc => '0,DXCC',
 181   name => '0,Name',
 182   itu => '0,ITU',
 183   cq => '0,CQ',
 184   utcoff => '0,UTC offset',
 185 );
 186
 187 no strict;
 188 sub AUTOLOAD
 189 {
 190   my $self = shift;
 191   my $name = $AUTOLOAD;
 192
 193   return if $name =~ /::DESTROY$/;
 194   $name =~ s/.*:://o;
 195
 196   confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 197   if (@_) {
 198     $self->{$name} = shift;
 199   }
 200   return $self->{$name};
 201 }
 202 use strict;
 203
 204 #
 205 # return a prompt for a field
 206 #
 207
 208 sub field_prompt
 209 {
 210   my ($self, $ele) = @_;
 211   return $valid{$ele};
 212 }
 213 1;
 214
 215 __END__