#
# 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 $lasttime $hits $matchtotal);
+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 = $matchtotal = 1; # cache stats
+$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 @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
if ($db) {
undef $db;
untie %pre;
%pre = ();
%prefix_loc = ();
+ $lru->close if $lru;
+ undef $lru;
}
- $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE) or confess "can't tie \%pre ($!)";
- my $out = $@ if $@;
- do "$main::data/prefix_data.pl" if !$out;
- $out = $@ if $@;
- # print Data::Dumper->Dump([\%pre, \%prefix_loc], [qw(pre prefix_loc)]);
- return $out;
+
+ # tie the main prefix database
+ eval {$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE);};
+ my $out = "$@($!)" if !$db || $@ ;
+ eval {do "$main::data/prefix_data.pl" if !$out; };
+ $out .= $@ if $@;
+ $lru = LRU->newbase('Prefix', $lrusize);
+
+ 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) = @_;
+ $call =~ s/^=//;
+ 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);
}
#
sub matchprefix
{
my $pref = shift;
+ my @partials;
for (my $i = length $pref; $i; $i--) {
$matchtotal++;
my $s = substr($pref, 0, $i);
- my $p = $cache{$s};
+ push @partials, $s;
+ my $p = $lru->get($s);
if ($p) {
$hits++;
if (isdbg('prefix')) {
- my $percent = $hits * 100 / $matchtotal;
- dbg("Partial Prefix Cache Hit: $s Hits: $hits of $matchtotal = $percent\%");
+ my $percent = sprintf "%.1f", $hits * 100 / $misses;
+ dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%");
}
+ lru_put($_, $p) for @partials;
return @$p;
} else {
+ $misses++;
my @out = get($s);
if (isdbg('prefix')) {
my $part = $out[0] || "*";
dbg("Partial prefix: $pref $s $part" );
}
if (@out && $out[0] eq $s) {
- $cache{$s} = \@out;
return @out;
- }
+ }
}
}
return ();
my $p;
my @parts;
my ($call, $sp, $i);
-
- # clear out the cache periodically to stop it growing for ever.
- if ($main::systime - $lasttime >= 15*60) {
- if (isdbg('prefix')) {
- my $percent = $hits * 100 / $matchtotal;
- dbg("Prefix Cache Cleared, Hits: $hits of $matchtotal = $percent\%") ;
- }
- my $percent = $hits * 100 / $matchtotal;
- dbg("Prefix Cache Cleared, $percent\% hits") if isdbg('prefix');
- %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 @nout;
+ my $ecall = "=$call";
+
+ # first check if this is a call (by prefixing it with an = sign)
+ my $p = $lru->get($ecall);
if ($p) {
$hits++;
if (isdbg('prefix')) {
- my $percent = $hits * 100 / $matchtotal;
- dbg("Prefix Cache Hit: $call Hits: $hits of $matchtotal = $percent\%");
+ my $percent = sprintf "%.1f", $hits * 100 / $misses;
+ dbg("Prefix Exact Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
}
push @out, @$p;
next;
- } else {
- @nout = get($call);
- if (@nout && $nout[0] eq $call) {
- $cache{$call} = \@nout;
- dbg("got exact prefix: $nout[0]") if isdbg('prefix');
- push @out, @nout;
- next;
+ }
+
+ # then 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)
+ $p = $lru->get($call);
+ if ($p) {
+ $hits++;
+ if (isdbg('prefix')) {
+ my $percent = sprintf "%.1f", $hits * 100 / $misses;
+ dbg("Prefix Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
}
+ push @out, @$p;
+ next;
+ }
+
+ # 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] = $ecall if @nout;
+ } else {
+
+ # try a straight get for an exact callsign
+ @nout = get($ecall);
+ }
+
+ # now store the exact prefix if it has been found
+ if (@nout && $nout[0] eq $ecall) {
+ $misses++;
+ $nout[0] = $call;
+ lru_put("=$call", \@nout);
+ dbg("got exact prefix: $nout[0]") if isdbg('prefix');
+ push @out, @nout;
+ next;
+ }
+
+ # now try a non-exact call/prefix
+ if ((@nout = get($call)) && $nout[0] eq $call) {
+ $misses++;
+ lru_put($call, \@nout);
+ dbg("got exact prefix: $nout[0]") if isdbg('prefix');
+ push @out, @nout;
+ next;
}
# now split the call into parts if required
@nout = get($s);
if (@nout && $nout[0] eq $s) {
dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
- $cache{$call} = \@nout;
+ $misses++;
+ lru_put($call, \@nout);
push @out, @nout;
next;
}
my @try = get($s);
if (@try && $try[0] eq $s) {
dbg("got 3 part prefix: $call $s") if isdbg('prefix');
- $cache{$call} = \@try;
+ $misses++;
+ lru_put($call, \@try);
push @out, @try;
next;
}
my @try = get($s);
if (@try && $try[0] eq $s) {
dbg("got 2 part prefix: $call $s") if isdbg('prefix');
- $cache{$call} = \@try;
+ $misses++;
+ lru_put($call, \@try);
push @out, @try;
next;
}
@nout = matchprefix($parts[0]);
if (@nout) {
dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
- $cache{$call} = \@nout;
+ $misses++;
+ lru_put($call, \@nout);
push @out, @nout;
next;
}
dbg("Compound prefix: $try $part" );
}
if (@try && $try eq $try[0]) {
- $cache{$call} = \@try;
+ $misses++;
+ lru_put($call, \@try);
push @out, @try;
} else {
- $cache{$call} = \@nout;
+ $misses++;
+ lru_put($call, \@nout);
push @out, @nout;
}
} else {
- $cache{$call} = \@nout;
+ $misses++;
+ lru_put($call, \@nout);
push @out, @nout;
}
next LM;
}
# we are a pirate!
- @nout = matchprefix('Q');
- $cache{$call} = \@nout;
+ @nout = matchprefix('QQ');
+ $misses++;
+ lru_put($call, \@nout);
push @out, @nout;
}
- if (isdbg('prefix')) {
+ if (isdbg('prefixdata')) {
my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
dbg($dd->Dumpxs);
}
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 = (
+ city => '0,City',
+ cont => '0,Continent',
+ cq => '0,CQ',
+ dxcc => '0,DXCC',
+ itu => '0,ITU',
lat => '0,Latitude,slat',
long => '0,Longitude,slong',
- dxcc => '0,DXCC',
name => '0,Name',
- itu => '0,ITU',
- cq => '0,CQ',
+ state => '0,State',
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
projects / spider.git / blobdiff