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 push @out, @nout if @nout;
153 next if @nout > 0 && $nout[0] eq $call;
155 # now split the call into parts if required
156 @parts = ($call =~ '/') ? split('/', $call) : ($call);
158 # remove any /0-9 /P /A /M /MM /AM suffixes etc
161 shift @parts if $p =~ /^(WEB|NET)$/o;
162 $p = $parts[$#parts];
163 pop @parts if $p =~ /^(\d+|[JPABM]|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/o;
164 $p = $parts[$#parts];
165 pop @parts if $p =~ /^(\d+|[JPABM]|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/o;
167 # can we resolve them by direct lookup
168 foreach $p (@parts) {
170 push @out, @nout if @nout;
171 next if @nout > 0 && $nout[0] eq $call;
175 # which is the shortest part (first if equal)?
176 dbg("Parts: $call = " . join('|', @parts)) if isdbg('prefix');
178 foreach $p (@parts) {
179 $sp = $p if length $p < length $sp;
181 $sp =~ s/-\d+$//; # remove any SSID
183 # # now start to resolve it from the left hand end
184 # for ($i = 1; $i <= length $sp; ++$i) {
185 # now start to resolve it from the right hand end
186 for ($i = length $sp; $i >= 1; --$i) {
187 my @wout = get(substr($sp, 0, $i));
188 next if @wout > 0 && $wout[0] gt $sp;
189 # last if @wout == 0;
194 if (isdbg('prefix')) {
195 my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
202 lat => '0,Latitude,slat',
203 long => '0,Longitude,slong',
208 utcoff => '0,UTC offset',
209 cont => '0,Continent',
216 my $name = $AUTOLOAD;
218 return if $name =~ /::DESTROY$/;
221 confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
222 # this clever line of code creates a subroutine which takes over from autoload
223 # from OO Perl - Conway
224 *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
226 $self->{$name} = shift;
228 return $self->{$name};
233 # return a prompt for a field
238 my ($self, $ele) = @_;