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