#
# Copyright (c) - Dirk Koopman G1TLH
#
-# $Id$
+#
#
package Prefix;
use Data::Dumper;
use DXDebug;
use DXUtil;
-
+use USDB;
+use LRU;
use strict;
-use vars qw($VERSION $BRANCH);
-$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
-$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0));
-$main::build += $VERSION;
-$main::branch += $BRANCH;
-
-use vars qw($db %prefix_loc %pre %cache $misses $hits $matchtotal $lasttime);
+use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal);
$db = undef; # the DB_File handle
%prefix_loc = (); # the meat of the info
%pre = (); # the prefix list
-%cache = (); # a runtime cache of matched prefixes
-$lasttime = 0; # last time this cache was cleared
$hits = $misses = $matchtotal = 1; # cache stats
+$lrusize = 1000; # size of prefix LRU cache
+
+sub init
+{
+ my $r = load();
+ return $r if $r;
+
+ # fix up the node's default country codes
+ unless (@main::my_cc) {
+ push @main::my_cc, (61..67) if $main::mycall =~ /^GB/;
+ push @main::my_cc, qw(EA EA6 EA8 EA9) if $main::mycall =~ /^E[ABCD]/;
+ push @main::my_cc, qw(I IT IS) if $main::mycall =~ /^I/;
+ push @main::my_cc, qw(SV SV5 SV9) if $main::mycall =~ /^SV/;
+
+ # catchall
+ push @main::my_cc, $main::mycall unless @main::my_cc;
+ }
-#my $cachefn = "$main::data/prefix_cache";
+ my @c;
+ for (@main::my_cc) {
+ if (/^\d+$/) {
+ push @c, $_;
+ } else {
+ my @dxcc = extract($_);
+ push @c, $dxcc[1]->dxcc if @dxcc > 1;
+ }
+ }
+ return "\@main::my_cc does not contain a valid prefix or callsign (" . join(',', @main::my_cc) . ")" unless @c;
+ @main::my_cc = @c;
+ return undef;
+}
sub load
{
# untie every thing
-# unlink $cachefn;
-
if ($db) {
undef $db;
untie %pre;
%pre = ();
%prefix_loc = ();
- untie %cache;
+ $lru->close if $lru;
+ undef $lru;
}
# tie the main prefix database
- $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE) or confess "can't tie \%pre ($!)";
- my $out = $@ if $@;
- do "$main::data/prefix_data.pl" if !$out;
- $out = $@ if $@;
+ eval {$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE);};
+ my $out = "$@($!)" if !$db || $@ ;
+ if (-e "$main::data/wpxloc.dat") {
+ $out .= load_wpxloc_dat("$main::data/wpxloc.dat");
+ $out .= load_wpxloc_dat("$main::data/local_wpxloc.dat");
+ } else {
+ eval {do "$main::data/prefix_data.pl" if !$out; };
+ $out .= $@ if $@;
+ }
+ $lru = LRU->newbase('Prefix', $lrusize);
- # tie the prefix cache
-# tie (%cache, "DB_File", $cachefn, O_RDWR|O_CREAT, 0664, $DB_HASH) or confess "can't tie prefix cache to $cachefn $!";
- return $out;
+ return $out;
+}
+
+sub loaded
+{
+ return $db;
}
sub store
return () if $db->seq($gotkey, $ref, R_NEXT);
return () if $key ne substr $gotkey, 0, length $key;
- return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
+ return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
+}
+
+#
+# put the key LRU incluing the city state info
+#
+
+sub lru_put
+{
+ my ($call, $ref) = @_;
+ my @s = USDB::get($call);
+
+ if (@s) {
+ # this is deep magic, because this is a reference to static data, it
+ # must be copied.
+ my $h = { %{$ref->[1]} };
+ bless $h, ref $ref->[1];
+ $h->{city} = $s[0];
+ $h->{state} = $s[1];
+ $ref->[1] = $h;
+ } else {
+ $ref->[1]->{city} = $ref->[1]->{state} = "" unless exists $ref->[1]->{state};
+ }
+
+ dbg("Prefix::lru_put $call -> ($ref->[1]->{city}, $ref->[1]->{state})") if isdbg('prefix');
+ $lru->put($call, $ref);
}
#
my $pref = shift;
my @partials;
- $pref =~ s/-\d+$//;
for (my $i = length $pref; $i; $i--) {
$matchtotal++;
my $s = substr($pref, 0, $i);
push @partials, $s;
- my $p = $cache{$s};
+ my $p = $lru->get($s);
if ($p) {
$hits++;
if (isdbg('prefix')) {
my $percent = sprintf "%.1f", $hits * 100 / $misses;
dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%");
}
- $cache{$_} = $p for @partials;
+ lru_put($_, $p) for @partials;
return @$p;
} else {
$misses++;
dbg("Partial prefix: $pref $s $part" );
}
if (@out && $out[0] eq $s) {
- $cache{$_} = \@out for @partials;
return @out;
}
}
my @parts;
my ($call, $sp, $i);
- # clear out the cache periodically to stop it growing for ever.
- if ($main::systime - $lasttime >= 20*60) {
- if (isdbg('prefix')) {
- my $percent = sprintf "%.1f", $hits * 100 / $misses;
- dbg("Prefix Cache Cleared, Hits: $hits/$misses of $matchtotal = $percent\%") ;
- }
- %cache =();
- $lasttime = $main::systime;
- $hits = $matchtotal = 0;
- }
-
LM: foreach $call (split /,/, $calls) {
# first check if the whole thing succeeds either because it is cached
# or because it simply is a stored prefix as callsign (or even a prefix)
$matchtotal++;
- my $p = $cache{$call};
+ $call =~ s/-\d+$//; # ignore SSIDs
+ my $p = $lru->get($call);
my @nout;
if ($p) {
$hits++;
push @out, @$p;
next;
} else {
- @nout = get($call);
+
+ # is it in the USDB, force a matchprefix to match?
+ my @s = USDB::get($call);
+ if (@s) {
+ @nout = get($call);
+ @nout = matchprefix($call) unless @nout;
+ $nout[0] = $call if @nout;
+ } else {
+ @nout = get($call);
+ }
+
+ # now store it
if (@nout && $nout[0] eq $call) {
$misses++;
- $cache{$call} = \@nout;
+ lru_put($call, \@nout);
dbg("got exact prefix: $nout[0]") if isdbg('prefix');
push @out, @nout;
next;
if (@nout && $nout[0] eq $s) {
dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
$misses++;
- $cache{$call} = \@nout;
+ lru_put($call, \@nout);
push @out, @nout;
next;
}
if (@try && $try[0] eq $s) {
dbg("got 3 part prefix: $call $s") if isdbg('prefix');
$misses++;
- $cache{$call} = \@try;
+ lru_put($call, \@try);
push @out, @try;
next;
}
if (@try && $try[0] eq $s) {
dbg("got 2 part prefix: $call $s") if isdbg('prefix');
$misses++;
- $cache{$call} = \@try;
+ lru_put($call, \@try);
push @out, @try;
next;
}
if (@nout) {
dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
$misses++;
- $cache{$call} = \@nout;
+ lru_put($call, \@nout);
push @out, @nout;
next;
}
}
if (@try && $try eq $try[0]) {
$misses++;
- $cache{$call} = \@try;
+ lru_put($call, \@try);
push @out, @try;
} else {
$misses++;
- $cache{$call} = \@nout;
+ lru_put($call, \@nout);
push @out, @nout;
}
} else {
$misses++;
- $cache{$call} = \@nout;
+ lru_put($call, \@nout);
push @out, @nout;
}
next LM;
# we are a pirate!
@nout = matchprefix('Q');
$misses++;
- $cache{$call} = \@nout;
+ lru_put($call, \@nout);
push @out, @nout;
}
return @out;
}
+#
+# turn a list of prefixes / dxcc numbers into a list of dxcc/itu/zone numbers
+#
+# nc = dxcc
+# ni = itu
+# nz = zone
+# ns = state
+#
+
+sub to_ciz
+{
+ my $cmd = shift;
+ my @out;
+
+ foreach my $v (@_) {
+ if ($cmd ne 'ns' && $v =~ /^\d+$/) {
+ push @out, $v unless grep $_ eq $v, @out;
+ } else {
+ if ($cmd eq 'ns' && $v =~ /^[A-Z][A-Z]$/i) {
+ push @out, uc $v unless grep $_ eq uc $v, @out;
+ } else {
+ my @pre = Prefix::extract($v);
+ if (@pre) {
+ shift @pre;
+ foreach my $p (@pre) {
+ my $n = $p->dxcc if $cmd eq 'nc' ;
+ $n = $p->itu if $cmd eq 'ni' ;
+ $n = $p->cq if $cmd eq 'nz' ;
+ $n = $p->state if $cmd eq 'ns';
+ push @out, $n unless grep $_ eq $n, @out;
+ }
+ }
+ }
+ }
+ }
+ return @out;
+}
+
+# get the full country data (dxcc, itu, cq, state, city) as a list
+# from a callsign.
+sub cty_data
+{
+ my $call = shift;
+
+ my @dxcc = extract($call);
+ if (@dxcc) {
+ my $state = $dxcc[1]->state || '';
+ my $city = $dxcc[1]->city || '';
+ my $name = $dxcc[1]->name || '';
+
+ return ($dxcc[1]->dxcc, $dxcc[1]->itu, $dxcc[1]->cq, $state, $city, $name);
+ }
+ return (666,0,0,'','','Pirate-Country-QQ');
+}
+
my %valid = (
lat => '0,Latitude,slat',
long => '0,Longitude,slong',
name => '0,Name',
itu => '0,ITU',
cq => '0,CQ',
+ state => '0,State',
+ city => '0,City',
utcoff => '0,UTC offset',
cont => '0,Continent',
);
-no strict;
sub AUTOLOAD
{
- my $self = shift;
+ no strict;
my $name = $AUTOLOAD;
return if $name =~ /::DESTROY$/;
- $name =~ s/.*:://o;
+ $name =~ s/^.*:://o;
confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
# this clever line of code creates a subroutine which takes over from autoload
# from OO Perl - Conway
- *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
- if (@_) {
- $self->{$name} = shift;
- }
- return $self->{$name};
+ *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
+ goto &$AUTOLOAD;
}
-use strict;
#
# return a prompt for a field
my ($self, $ele) = @_;
return $valid{$ele};
}
+
+sub load_wpxloc_dat
+{
+ my $fn = shift;
+ my $out;
+ my $id = 0;
+ my $line = 0;
+
+ return unless -e $fn;
+
+ my $in = IO::File->new("$fn");
+ $out = "error opening $fn $!", return $out unless $in;
+ while (<$in>) {
+ my $ignore = 0;
+ $line++;
+
+ next if /^\s*[!#]/;
+ next if /^\s*$/;
+ s/\s+$//;
+
+ my @f = split;
+
+ # The format of wpxloc.dat is:-
+ # 1S Spratly-Islands-1S 269 AS 50 26 8.00 9 53 N 114 14 E
+ # & 1S,9M0,BV9S,=9M6US/0,=DU0K
+ # & .... can repeat ad nausium
+
+ unless ($f[0] eq '&') {
+ # main location definition and 'official' canonical prefix/tag for this locality
+ # NOTE: we assume that the file is nominally correct and that any alterations
+ # will overwrite existing entries
+ #
+ # The order is: prefix, description, country-no, continent, itu, cq, utc-offset
+ # lat degrees, lat minutes, lat N/S, long degrees, long minutes,
+ # long E/W
+
+ if (@f != 13) {
+ $out .= "wrong no of items for locality on line $line\n";
+ $ignore++;
+ next;
+ }
+
+ $ignore = 0;
+
+ my $e = bless {}, 'Prefix';
+ $id++;
+
+ $e->{name} = $f[1];
+ $e->{dxcc} = $f[2];
+ $e->{cont} = $f[3];
+ $e->{itu} = $f[4];
+ $e->{cq} = $f[5];
+ $e->{utcoff} = $f[6];
+ $e->{lat} = $f[7] + ($f[8] / 60);
+ $e->{lat} = -$e->{lat} if $f[9] eq 'S';
+ $e->{long} = $f[10] + ($f[11] / 60);
+ $e->{long} = -$e->{long} if $f[12] eq 'W';
+ $prefix_loc{$id} = $e;
+ $pre{"$f[0]"} = $id;
+
+# print "line $line, $f[0]\n";
+
+ } else {
+ # additional prefixes and full callsigns (indicated with an prefix of '=')
+
+ next if $ignore;
+
+ shift @f;
+ foreach my $gob (@f) {
+ my @ent = split /\s*,\s*/, $gob;
+ foreach my $ent (@ent) {
+ $ent =~ s/^\*//;
+ my $ref = $pre{$ent};
+ if ($ref) {
+ my @id = split /,/, $ref;
+ push @id, $id unless grep {$id == $_} @id;
+ $pre{$ent} = join ',', @id;
+ } else {
+ $pre{$ent} = $id;
+ }
+ }
+ }
+ }
+ }
+ $in->close;
+
+ open POUT, ">/tmp/prefix_data";
+ print POUT Data::Dumper->Dump([\%prefix_loc, \%pre], [qw(%prefix_loc %pre)]);
+ close POUT;
+
+ return $out;
+}
+
1;
__END__