4 # Copyright (c) - Dirk Koopman G1TLH
19 use vars qw($VERSION $BRANCH);
20 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
21 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0;
22 $main::build += $VERSION;
23 $main::branch += $BRANCH;
25 use vars qw($db %prefix_loc %pre);
27 $db = undef; # the DB_File handle
28 %prefix_loc = (); # the meat of the info
29 %pre = (); # the prefix list
39 $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE) or confess "can't tie \%pre ($!)";
41 do "$main::data/prefix_data.pl" if !$out;
43 # print Data::Dumper->Dump([\%pre, \%prefix_loc], [qw(pre prefix_loc)]);
50 my $fh = new IO::File;
51 my $fn = "$main::data/prefix_data.pl";
53 confess "Prefix system not started" if !$db;
56 rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
57 rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
58 rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
59 rename "$fn.o", "$fn.oo" if -e "$fn.o";
60 rename "$fn", "$fn.o" if -e "$fn";
62 $fh->open(">$fn") or die "Can't open $fn ($!)";
64 # prefix location data
65 $fh->print("%prefix_loc = (\n");
66 foreach $l (sort {$a <=> $b} keys %prefix_loc) {
67 my $r = $prefix_loc{$l};
68 $fh->printf(" $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
69 $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
74 $fh->print("%pre = (\n");
75 foreach $k (sort keys %pre) {
76 $fh->print(" '$k' => [");
77 my @list = @{$pre{$k}};
84 $fh->print("$str ],\n");
91 # what you get is a list that looks like:-
93 # prefix => @list of blessed references to prefix_locs
95 # This routine will only do what you ask for, if you wish to be intelligent
96 # then that is YOUR problem!
107 return () if $db->seq($gotkey, $ref, R_CURSOR);
108 return () if $key ne substr $gotkey, 0, length $key;
110 @outref = map { $prefix_loc{$_} } split ',', $ref;
111 return ($gotkey, @outref);
115 # get the next key that matches, this assumes that you have done a 'get' first
126 return () if $db->seq($gotkey, $ref, R_NEXT);
127 return () if $key ne substr $gotkey, 0, length $key;
129 @outref = map { $prefix_loc{$_} } split ',', $ref;
130 return ($gotkey, @outref);
134 # extract a 'prefix' from a callsign, in other words the largest entity that will
135 # obtain a result from the prefix table.
137 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
138 # G1TLH/VO1 (should) return VO1
143 my $calls = uc shift;
149 foreach $call (split /,/, $calls) {
150 # first check if the whole thing succeeds
151 my @nout = get($call);
152 if (@nout && $nout[0] eq $call) {
153 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
158 # now split the call into parts if required
159 @parts = ($call =~ '/') ? split('/', $call) : ($call);
161 # remove any /0-9 /P /A /M /MM /AM suffixes etc
164 shift @parts if $p =~ /^(WEB|NET)$/o;
165 $p = $parts[$#parts];
166 pop @parts if $p =~ /^(\d+|[JPABM]|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/o;
167 $p = $parts[$#parts];
168 pop @parts if $p =~ /^(\d+|[JPABM]|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/o;
170 # can we resolve them by direct lookup
171 foreach $p (@parts) {
173 if (@nout && $nout[0] eq $call) {
174 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
181 # which is the shortest part (first if equal)?
182 dbg("Parts: $call = " . join(' ', @parts)) if isdbg('prefix');
187 L1: for ($n = 0; $n < @parts; $n++) {
190 for ($i = $k = 0; $i < @parts; $i++) {
191 next if $checked[$i];
193 if (!$sp || length $p < length $sp) {
194 dbg("try part: $p") if isdbg('prefix');
200 $sp =~ s/-\d+$//; # remove any SSID
202 # # now start to resolve it from the left hand end
203 # for ($i = 1; $i <= length $sp; ++$i) {
204 # now start to resolve it from the right hand end
205 for ($i = length $sp; $i >= 1; --$i) {
206 my $ssp = substr($sp, 0, $i);
207 my @wout = get($ssp);
208 if (isdbg('prefix')) {
209 my $part = $wout[0] || "*";
210 $part .= '*' unless $part eq '*' || $part eq $ssp;
211 dbg("Partial prefix: $sp $ssp $part" );
213 next if @wout > 0 && $wout[0] gt $ssp;
215 # try and search for it in the descriptions as
216 # a whole callsign if it has multiple parts and the output
217 # is more two long, this should catch things like
218 # FR5DX/T without having to explicitly stick it into
224 my $try = join('/', @parts);
226 if (isdbg('prefix')) {
227 my $part = $try[0] || "*";
228 $part .= '*' unless $part eq '*' || $part eq $try;
229 dbg("Compound prefix: $try $part" );
231 if (@try && $try eq $try[0]) {
244 if (isdbg('prefix')) {
245 my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
252 lat => '0,Latitude,slat',
253 long => '0,Longitude,slong',
258 utcoff => '0,UTC offset',
259 cont => '0,Continent',
266 my $name = $AUTOLOAD;
268 return if $name =~ /::DESTROY$/;
271 confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
272 # this clever line of code creates a subroutine which takes over from autoload
273 # from OO Perl - Conway
274 *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
276 $self->{$name} = shift;
278 return $self->{$name};
283 # return a prompt for a field
288 my ($self, $ele) = @_;