4 # Copyright (c) - Dirk Koopman G1TLH
21 use vars qw($VERSION $BRANCH);
22 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
23 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0));
24 $main::build += $VERSION;
25 $main::branch += $BRANCH;
27 use vars qw($db %prefix_loc %pre %cache $misses $hits $matchtotal $lasttime);
29 $db = undef; # the DB_File handle
30 %prefix_loc = (); # the meat of the info
31 %pre = (); # the prefix list
32 %cache = (); # a runtime cache of matched prefixes
33 $lasttime = 0; # last time this cache was cleared
34 $hits = $misses = $matchtotal = 1; # cache stats
36 #my $cachefn = "$main::data/prefix_cache";
51 # tie the main prefix database
52 $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE) or confess "can't tie \%pre ($!)";
54 do "$main::data/prefix_data.pl" if !$out;
57 # tie the prefix cache
58 # tie (%cache, "DB_File", $cachefn, O_RDWR|O_CREAT, 0664, $DB_HASH) or confess "can't tie prefix cache to $cachefn $!";
65 my $fh = new IO::File;
66 my $fn = "$main::data/prefix_data.pl";
68 confess "Prefix system not started" if !$db;
71 rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
72 rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
73 rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
74 rename "$fn.o", "$fn.oo" if -e "$fn.o";
75 rename "$fn", "$fn.o" if -e "$fn";
77 $fh->open(">$fn") or die "Can't open $fn ($!)";
79 # prefix location data
80 $fh->print("%prefix_loc = (\n");
81 foreach $l (sort {$a <=> $b} keys %prefix_loc) {
82 my $r = $prefix_loc{$l};
83 $fh->printf(" $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
84 $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
89 $fh->print("%pre = (\n");
90 foreach $k (sort keys %pre) {
91 $fh->print(" '$k' => [");
92 my @list = @{$pre{$k}};
99 $fh->print("$str ],\n");
106 # what you get is a list that looks like:-
108 # prefix => @list of blessed references to prefix_locs
110 # This routine will only do what you ask for, if you wish to be intelligent
111 # then that is YOUR problem!
119 return () if $db->seq($gotkey, $ref, R_CURSOR);
120 return () if $key ne substr $gotkey, 0, length $key;
122 return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
126 # get the next key that matches, this assumes that you have done a 'get' first
135 return () if $db->seq($gotkey, $ref, R_NEXT);
136 return () if $key ne substr $gotkey, 0, length $key;
138 return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
142 # search for the nearest match of a prefix string (starting
143 # from the RH end of the string passed)
152 for (my $i = length $pref; $i; $i--) {
154 my $s = substr($pref, 0, $i);
159 if (isdbg('prefix')) {
160 my $percent = sprintf "%.1f", $hits * 100 / $misses;
161 dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%");
163 $cache{$_} = $p for @partials;
168 if (isdbg('prefix')) {
169 my $part = $out[0] || "*";
170 $part .= '*' unless $part eq '*' || $part eq $s;
171 dbg("Partial prefix: $pref $s $part" );
173 if (@out && $out[0] eq $s) {
174 $cache{$_} = \@out for @partials;
183 # extract a 'prefix' from a callsign, in other words the largest entity that will
184 # obtain a result from the prefix table.
186 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
187 # G1TLH/VO1 (should) return VO1
192 my $calls = uc shift;
198 # clear out the cache periodically to stop it growing for ever.
199 if ($main::systime - $lasttime >= 20*60) {
200 if (isdbg('prefix')) {
201 my $percent = sprintf "%.1f", $hits * 100 / $misses;
202 dbg("Prefix Cache Cleared, Hits: $hits/$misses of $matchtotal = $percent\%") ;
205 $lasttime = $main::systime;
206 $hits = $matchtotal = 0;
209 LM: foreach $call (split /,/, $calls) {
211 # first check if the whole thing succeeds either because it is cached
212 # or because it simply is a stored prefix as callsign (or even a prefix)
214 my $p = $cache{$call};
218 if (isdbg('prefix')) {
219 my $percent = sprintf "%.1f", $hits * 100 / $misses;
220 dbg("Prefix Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
226 if (@nout && $nout[0] eq $call) {
228 $cache{$call} = \@nout;
229 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
235 # now split the call into parts if required
236 @parts = ($call =~ '/') ? split('/', $call) : ($call);
237 dbg("Parts: $call = " . join(' ', @parts)) if isdbg('prefix');
239 # remove any /0-9 /P /A /M /MM /AM suffixes etc
241 @parts = grep { !/^\d+$/ && !/^[PABM]$/ && !/^(?:|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/; } @parts;
243 # can we resolve them by direct lookup
244 my $s = join('/', @parts);
246 if (@nout && $nout[0] eq $s) {
247 dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
249 $cache{$call} = \@nout;
254 dbg("Parts now: $call = " . join(' ', @parts)) if isdbg('prefix');
256 # at this point we should have two or three parts
257 # if it is three parts then join the first and last parts together
260 # first deal with prefix/x00xx/single letter things
261 if (@parts == 3 && length $parts[0] <= length $parts[1]) {
262 @nout = matchprefix($parts[0]);
264 my $s = join('/', $nout[0], $parts[2]);
266 if (@try && $try[0] eq $s) {
267 dbg("got 3 part prefix: $call $s") if isdbg('prefix');
269 $cache{$call} = \@try;
274 # if the second part is a callsign and the last part is one letter
275 if (is_callsign($parts[1]) && length $parts[2] == 1) {
281 # if it is a two parter
284 # try it as it is as compound, taking the first part as the prefix
285 @nout = matchprefix($parts[0]);
287 my $s = join('/', $nout[0], $parts[1]);
289 if (@try && $try[0] eq $s) {
290 dbg("got 2 part prefix: $call $s") if isdbg('prefix');
292 $cache{$call} = \@try;
299 # remove the problematic /J suffix
300 pop @parts if @parts > 1 && $parts[$#parts] eq 'J';
304 @nout = matchprefix($parts[0]);
306 dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
308 $cache{$call} = \@nout;
317 L1: for ($n = 0; $n < @parts; $n++) {
320 for ($i = $k = 0; $i < @parts; $i++) {
321 next if $checked[$i];
323 if (!$sp || length $p < length $sp) {
324 dbg("try part: $p") if isdbg('prefix');
330 $sp =~ s/-\d+$//; # remove any SSID
332 # now start to resolve it from the right hand end
333 @nout = matchprefix($sp);
335 # try and search for it in the descriptions as
336 # a whole callsign if it has multiple parts and the output
337 # is more two long, this should catch things like
338 # FR5DX/T without having to explicitly stick it into
343 $parts[$k] = $nout[0];
344 my $try = join('/', @parts);
346 if (isdbg('prefix')) {
347 my $part = $try[0] || "*";
348 $part .= '*' unless $part eq '*' || $part eq $try;
349 dbg("Compound prefix: $try $part" );
351 if (@try && $try eq $try[0]) {
353 $cache{$call} = \@try;
357 $cache{$call} = \@nout;
362 $cache{$call} = \@nout;
370 @nout = matchprefix('Q');
372 $cache{$call} = \@nout;
376 if (isdbg('prefixdata')) {
377 my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
384 lat => '0,Latitude,slat',
385 long => '0,Longitude,slong',
390 utcoff => '0,UTC offset',
391 cont => '0,Continent',
398 my $name = $AUTOLOAD;
400 return if $name =~ /::DESTROY$/;
403 confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
404 # this clever line of code creates a subroutine which takes over from autoload
405 # from OO Perl - Conway
406 *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
408 $self->{$name} = shift;
410 return $self->{$name};
415 # return a prompt for a field
420 my ($self, $ele) = @_;