]> scm.dxcluster.org Git - spider.git/blob - perl/Prefix.pm
removed ~ from the end of a PC18
[spider.git] / 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__