4 # Copyright (c) - Dirk Koopman G1TLH
22 use vars qw($VERSION $BRANCH);
23 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
24 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0));
25 $main::build += $VERSION;
26 $main::branch += $BRANCH;
28 use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal);
30 $db = undef; # the DB_File handle
31 %prefix_loc = (); # the meat of the info
32 %pre = (); # the prefix list
33 $hits = $misses = $matchtotal = 1; # cache stats
34 $lrusize = 1000; # size of prefix LRU cache
41 # fix up the node's default country codes
42 unless (@main::my_cc) {
43 push @main::my_cc, (61..67) if $main::mycall =~ /^GB/;
44 push @main::my_cc, qw(EA EA6 EA8 EA9) if $main::mycall =~ /^E[ABCD]/;
45 push @main::my_cc, qw(I IT IS) if $main::mycall =~ /^I/;
46 push @main::my_cc, qw(SV SV5 SV9) if $main::mycall =~ /^SV/;
49 push @main::my_cc, $main::mycall unless @main::my_cc;
57 my @dxcc = extract($_);
58 push @c, $dxcc[1]->dxcc if @dxcc > 1;
61 return "\@main::my_cc does not contain a valid prefix or callsign (" . join(',', @main::my_cc) . ")" unless @c;
78 # tie the main prefix database
79 $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE) or confess "can't tie \%pre ($!)";
81 do "$main::data/prefix_data.pl" if !$out;
83 $lru = LRU->newbase('Prefix', $lrusize);
91 my $fh = new IO::File;
92 my $fn = "$main::data/prefix_data.pl";
94 confess "Prefix system not started" if !$db;
97 rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
98 rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
99 rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
100 rename "$fn.o", "$fn.oo" if -e "$fn.o";
101 rename "$fn", "$fn.o" if -e "$fn";
103 $fh->open(">$fn") or die "Can't open $fn ($!)";
105 # prefix location data
106 $fh->print("%prefix_loc = (\n");
107 foreach $l (sort {$a <=> $b} keys %prefix_loc) {
108 my $r = $prefix_loc{$l};
109 $fh->printf(" $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
110 $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
112 $fh->print(");\n\n");
115 $fh->print("%pre = (\n");
116 foreach $k (sort keys %pre) {
117 $fh->print(" '$k' => [");
118 my @list = @{$pre{$k}};
125 $fh->print("$str ],\n");
132 # what you get is a list that looks like:-
134 # prefix => @list of blessed references to prefix_locs
136 # This routine will only do what you ask for, if you wish to be intelligent
137 # then that is YOUR problem!
145 return () if $db->seq($gotkey, $ref, R_CURSOR);
146 return () if $key ne substr $gotkey, 0, length $key;
148 return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
152 # get the next key that matches, this assumes that you have done a 'get' first
161 return () if $db->seq($gotkey, $ref, R_NEXT);
162 return () if $key ne substr $gotkey, 0, length $key;
164 return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
168 # put the key LRU incluing the city state info
173 my ($call, $ref) = @_;
174 my @s = USDB::get($call);
177 # this is deep magic, because this is a reference to static data, it
179 my $h = { %{$ref->[1]} };
180 bless $h, ref $ref->[1];
185 $ref->[1]->{city} = $ref->[1]->{state} = "" unless exists $ref->[1]->{state};
188 dbg("Prefix::lru_put $call -> ($ref->[1]->{city}, $ref->[1]->{state})") if isdbg('prefix');
189 $lru->put($call, $ref);
193 # search for the nearest match of a prefix string (starting
194 # from the RH end of the string passed)
202 for (my $i = length $pref; $i; $i--) {
204 my $s = substr($pref, 0, $i);
206 my $p = $lru->get($s);
209 if (isdbg('prefix')) {
210 my $percent = sprintf "%.1f", $hits * 100 / $misses;
211 dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%");
213 lru_put($_, $p) for @partials;
218 if (isdbg('prefix')) {
219 my $part = $out[0] || "*";
220 $part .= '*' unless $part eq '*' || $part eq $s;
221 dbg("Partial prefix: $pref $s $part" );
223 if (@out && $out[0] eq $s) {
232 # extract a 'prefix' from a callsign, in other words the largest entity that will
233 # obtain a result from the prefix table.
235 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
236 # G1TLH/VO1 (should) return VO1
241 my $calls = uc shift;
247 LM: foreach $call (split /,/, $calls) {
249 # first check if the whole thing succeeds either because it is cached
250 # or because it simply is a stored prefix as callsign (or even a prefix)
252 $call =~ s/-\d+$//; # ignore SSIDs
253 my $p = $lru->get($call);
257 if (isdbg('prefix')) {
258 my $percent = sprintf "%.1f", $hits * 100 / $misses;
259 dbg("Prefix Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
265 # is it in the USDB, force a matchprefix to match?
266 my @s = USDB::get($call);
269 @nout = matchprefix($call) unless @nout;
270 $nout[0] = $call if @nout;
276 if (@nout && $nout[0] eq $call) {
278 lru_put($call, \@nout);
279 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
285 # now split the call into parts if required
286 @parts = ($call =~ '/') ? split('/', $call) : ($call);
287 dbg("Parts: $call = " . join(' ', @parts)) if isdbg('prefix');
289 # remove any /0-9 /P /A /M /MM /AM suffixes etc
291 @parts = grep { !/^\d+$/ && !/^[PABM]$/ && !/^(?:|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/; } @parts;
293 # can we resolve them by direct lookup
294 my $s = join('/', @parts);
296 if (@nout && $nout[0] eq $s) {
297 dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
299 lru_put($call, \@nout);
304 dbg("Parts now: $call = " . join(' ', @parts)) if isdbg('prefix');
306 # at this point we should have two or three parts
307 # if it is three parts then join the first and last parts together
310 # first deal with prefix/x00xx/single letter things
311 if (@parts == 3 && length $parts[0] <= length $parts[1]) {
312 @nout = matchprefix($parts[0]);
314 my $s = join('/', $nout[0], $parts[2]);
316 if (@try && $try[0] eq $s) {
317 dbg("got 3 part prefix: $call $s") if isdbg('prefix');
319 lru_put($call, \@try);
324 # if the second part is a callsign and the last part is one letter
325 if (is_callsign($parts[1]) && length $parts[2] == 1) {
331 # if it is a two parter
334 # try it as it is as compound, taking the first part as the prefix
335 @nout = matchprefix($parts[0]);
337 my $s = join('/', $nout[0], $parts[1]);
339 if (@try && $try[0] eq $s) {
340 dbg("got 2 part prefix: $call $s") if isdbg('prefix');
342 lru_put($call, \@try);
349 # remove the problematic /J suffix
350 pop @parts if @parts > 1 && $parts[$#parts] eq 'J';
354 @nout = matchprefix($parts[0]);
356 dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
358 lru_put($call, \@nout);
367 L1: for ($n = 0; $n < @parts; $n++) {
370 for ($i = $k = 0; $i < @parts; $i++) {
371 next if $checked[$i];
373 if (!$sp || length $p < length $sp) {
374 dbg("try part: $p") if isdbg('prefix');
380 $sp =~ s/-\d+$//; # remove any SSID
382 # now start to resolve it from the right hand end
383 @nout = matchprefix($sp);
385 # try and search for it in the descriptions as
386 # a whole callsign if it has multiple parts and the output
387 # is more two long, this should catch things like
388 # FR5DX/T without having to explicitly stick it into
393 $parts[$k] = $nout[0];
394 my $try = join('/', @parts);
396 if (isdbg('prefix')) {
397 my $part = $try[0] || "*";
398 $part .= '*' unless $part eq '*' || $part eq $try;
399 dbg("Compound prefix: $try $part" );
401 if (@try && $try eq $try[0]) {
403 lru_put($call, \@try);
407 lru_put($call, \@nout);
412 lru_put($call, \@nout);
420 @nout = matchprefix('Q');
422 lru_put($call, \@nout);
426 if (isdbg('prefixdata')) {
427 my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
434 # turn a list of prefixes / dxcc numbers into a list of dxcc/itu/zone numbers
448 if ($cmd ne 'ns' && $v =~ /^\d+$/) {
449 push @out, $v unless grep $_ eq $v, @out;
451 if ($cmd eq 'ns' && $v =~ /^[A-Z][A-Z]$/i) {
452 push @out, uc $v unless grep $_ eq uc $v, @out;
454 my @pre = Prefix::extract($v);
457 foreach my $p (@pre) {
458 my $n = $p->dxcc if $cmd eq 'nc' ;
459 $n = $p->itu if $cmd eq 'ni' ;
460 $n = $p->cq if $cmd eq 'nz' ;
461 $n = $p->state if $cmd eq 'ns';
462 push @out, $n unless grep $_ eq $n, @out;
472 lat => '0,Latitude,slat',
473 long => '0,Longitude,slong',
480 utcoff => '0,UTC offset',
481 cont => '0,Continent',
487 my $name = $AUTOLOAD;
489 return if $name =~ /::DESTROY$/;
492 confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
493 # this clever line of code creates a subroutine which takes over from autoload
494 # from OO Perl - Conway
495 *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
500 # return a prompt for a field
505 my ($self, $ele) = @_;