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