X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FPrefix.pm;h=10559711961130312a3829198c64bce1daa6372f;hb=76b23ebfd5384033ecefd8bed4babfeb12d103e9;hp=005d3309020ec41cf61093fc8ec33aa0e91c0e60;hpb=6a98ae5890ea507e2687fcb9e783c4a26127e557;p=spider.git diff --git a/perl/Prefix.pm b/perl/Prefix.pm index 005d3309..10559711 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -14,7 +14,7 @@ use DB_File; use Data::Dumper; use DXDebug; use DXUtil; - +use LRU; use strict; @@ -24,29 +24,33 @@ $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 = 2000; # size of prefix LRU cache + +$lru = LRU->newbase('Prefix', $lrusize); sub load { + # untie every thing if ($db) { undef $db; untie %pre; %pre = (); %prefix_loc = (); } - $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE) or confess "can't tie \%pre ($!)"; + + # 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 $@; - # print Data::Dumper->Dump([\%pre, \%prefix_loc], [qw(pre prefix_loc)]); - return $out; + + return $out; } sub store @@ -136,16 +140,34 @@ sub next sub matchprefix { my $pref = shift; + my @partials; for (my $i = length $pref; $i; $i--) { + $matchtotal++; my $s = substr($pref, 0, $i); - my @out = get($s); - if (isdbg('prefix')) { - my $part = $out[0] || "*"; - $part .= '*' unless $part eq '*' || $part eq $s; - dbg("Partial prefix: $pref $s $part" ); - } - return @out if @out && $out[0] eq $s; + push @partials, $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\%"); + } + $lru->put($_, $p) for @partials; + return @$p; + } else { + $misses++; + my @out = get($s); + if (isdbg('prefix')) { + my $part = $out[0] || "*"; + $part .= '*' unless $part eq '*' || $part eq $s; + dbg("Partial prefix: $pref $s $part" ); + } + if (@out && $out[0] eq $s) { + $lru->put($_, \@out) for @partials; + return @out; + } + } } return (); } @@ -165,39 +187,28 @@ sub extract 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 $p = $lru->get($call); my @nout; 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 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; + $misses++; + $lru->put($call, \@nout); dbg("got exact prefix: $nout[0]") if isdbg('prefix'); push @out, @nout; next; @@ -217,7 +228,8 @@ LM: foreach $call (split /,/, $calls) { @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; } @@ -236,7 +248,8 @@ LM: foreach $call (split /,/, $calls) { 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; } @@ -258,7 +271,8 @@ LM: foreach $call (split /,/, $calls) { 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; } @@ -272,8 +286,9 @@ LM: foreach $call (split /,/, $calls) { if (@parts == 1) { @nout = matchprefix($parts[0]); if (@nout) { - dbg("got prefix: $call ]") if isdbg('prefix'); - $cache{$call} = \@nout; + dbg("got prefix: $call = $nout[0]") if isdbg('prefix'); + $misses++; + $lru->put($call, \@nout); push @out, @nout; next; } @@ -317,14 +332,17 @@ L1: for ($n = 0; $n < @parts; $n++) { 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; @@ -333,11 +351,12 @@ L1: for ($n = 0; $n < @parts; $n++) { # we are a pirate! @nout = matchprefix('Q'); - $cache{$call} = \@nout; + $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); }