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 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 IO::File;
  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[0];
 153                 shift @parts if $p =~ /^(WEB|NET)$/o;
 154                 $p = $parts[$#parts];
 155                 pop @parts if $p =~ /^(\d+|[JPABM]|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/o;
 156                 $p = $parts[$#parts];
 157                 pop @parts if $p =~ /^(\d+|[JPABM]|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/o;
 158
 159                 # can we resolve them by direct lookup
 160                 foreach $p (@parts) {
 161                         @out = get($p);
 162                         return @out if @out > 0 && $out[0] eq $call;
 163                 }
 164         }
 165
 166         # which is the shortest part (first if equal)?
 167         $sp = $parts[0];
 168         foreach $p (@parts) {
 169                 $sp = $p if length $sp > length $p;
 170         }
 171         # now start to resolve it from the left hand end
 172         for (@out = (), $i = 1; $i <= length $sp; ++$i) {
 173                 @nout = get(substr($sp, 0, $i));
 174                 last if @nout > 0 && $nout[0] gt $sp;
 175                 last if @nout == 0;
 176                 @out = @nout;
 177         }
 178
 179         # not found
 180         return (@out > 0) ? @out : ();
 181 }
 182
 183 my %valid = (
 184                          lat => '0,Latitude,slat',
 185                          long => '0,Longitude,slong',
 186                          dxcc => '0,DXCC',
 187                          name => '0,Name',
 188                          itu => '0,ITU',
 189                          cq => '0,CQ',
 190                          utcoff => '0,UTC offset',
 191                          cont => '0,Continent',
 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         # this clever line of code creates a subroutine which takes over from autoload
 205         # from OO Perl - Conway
 206         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 207         if (@_) {
 208                 $self->{$name} = shift;
 209         }
 210         return $self->{$name};
 211 }
 212 use strict;
 213
 214 #
 215 # return a prompt for a field
 216 #
 217
 218 sub field_prompt
 219 {
 220         my ($self, $ele) = @_;
 221         return $valid{$ele};
 222 }
 223 1;
 224
 225 __END__