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