+29Sep02=======================================================================
+1. Added LRU caching to DXUsers and Prefix.
28Sep02=======================================================================
1. Put some transparent caching into Prefix.pm to see if this has a
performance impact.
# constructor
sub new
{
- my $name = shift;
- my $ref = shift;
+ my $pkg = shift;
+ my $name = ref $pkg || $pkg;
+
my $self = [];
- push @$self, $self, $self, $ref;
+ push @$self, $self, $self, @_;
return bless $self, $name;
}
$docheck && _check($p);
- my $q = ref $ref && $ref->isa('Chain') ? $ref : new Chain $ref;
+ my $q = ref $ref && $ref->isa('Chain') ? $ref : Chain->new($ref);
$q->[PREV] = $p->[PREV];
$q->[NEXT] = $p;
$p->[PREV]->[NEXT] = $q;
$docheck && _check($p);
- $p->[PREV]->[NEXT] = $p->[NEXT];
+ my $q = $p->[PREV]->[NEXT] = $p->[NEXT];
$p->[NEXT]->[PREV] = $p->[PREV];
- return $p->[PREV];
+ $p->[NEXT] = $p->[PREV] = undef;
+ return $q;
}
# Is this chain empty?
$docheck && _check($base);
- return $base->[NEXT] == $base ? undef : $base->[PREV] unless $p;
+ return $base->[PREV] == $base ? undef : $base->[PREV] unless $p;
$docheck && _check($p);
=head1 SYNOPSIS
use Chain;
- $base = new Chain;
- $p->ins($ref);
- $p->add($ref);
+ $base = new Chain [$obj];
+ $p->ins($ref [,$obj]);
+ $p->add($ref [,$obj]);
$ref = $p->obj or $p->obj($ref);
$q = $base->next($p);
$q = $base->prev($p);
# add this station to the user database, if required
my $user = DXUser->get_current($call);
- $user = DXUser->new($call) if !$user;
+ $user = DXUser->new($call) unless $user;
if ($field[2] == 1) {
$user->name($field[3]);
use IO::File;
use DXDebug;
use DXUtil;
+use LRU;
use strict;
$main::build += $VERSION;
$main::branch += $BRANCH;
-use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime);
+use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize);
%u = ();
$dbm = undef;
$filename = undef;
$lastoperinterval = 60*24*60*60;
$lasttime = 0;
+$lrusize = 500;
# hash of valid elements and a simple prompt
%valid = (
}
$filename = $fn;
+ $lru = LRU->newbase("DXUser", $lrusize);
}
sub del_file
my $pkg = shift;
my $call = uc shift;
my $data;
+
+ # is it in the LRU cache?
+ my $ref = $lru->get($call);
+ return $ref if $ref;
+
+ # search for it
unless ($dbm->get($call, $data)) {
- return decode($data);
+ $ref = decode($data);
+ $lru->put($call, $ref);
+ return $ref;
}
return undef;
}
$dbm->del($call);
delete $self->{annok} if $self->{annok};
delete $self->{dxok} if $self->{dxok};
- $dbm->put($call, $self->encode);
+ $lru->put($call, $self);
+ my $ref = $self->encode;
+ $dbm->put($call, $ref);
}
#
# for ($dbm->get_dup($call)) {
# $dbm->del_dup($call, $_);
# }
+ $lru->remove($call);
$dbm->del($call);
}
--- /dev/null
+#
+# A class implimenting LRU sematics with hash look up
+#
+# Copyright (c) 2002 Dirk Koopman, Tobit Computer Co Ltd
+#
+# $Id$
+#
+# The structure of the objects stored are:-
+#
+# [next, prev, obj, callsign]
+#
+# The structure of the base is:-
+#
+# [next, prev, max objects, count ]
+#
+#
+
+package LRU;
+
+
+use strict;
+use Chain;
+use DXVars;
+use DXDebug;
+
+use vars qw(@ISA);
+@ISA = qw(Chain);
+
+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;
+
+sub newbase
+{
+ my $pkg = shift;
+ my $name = shift;
+ my $max = shift;
+ confess "LRU->newbase requires a name and maximal count" unless $name && $max;
+ return $pkg->SUPER::new({ }, $max, 0, $name);
+}
+
+sub get
+{
+ my ($self, $call) = @_;
+ if (my $p = $self->obj->{$call}) {
+ dbg("LRU $self->[5] cache hit $call") if isdbg('lru');
+ $self->rechain($p);
+ return $p->obj;
+ }
+ return undef;
+}
+
+sub put
+{
+ my ($self, $call, $ref) = @_;
+ confess("need a call and a reference") unless $call && $ref;
+ my $p = $self->obj->{$call};
+ if ($p) {
+ # update the reference and rechain it
+ dbg("LRU $self->[5] cache update $call") if isdbg('lru');
+ $p->obj($ref);
+ $self->rechain($p);
+ } else {
+ # delete one of the end of the chain if required
+ while ($self->[4] >= $self->[3] ) {
+ $p = $self->prev;
+ my $call = $p->[3];
+ dbg("LRU $self->[5] cache LRUed out $call now $self->[4]/$self->[3]") if isdbg('lru');
+ $self->remove($call);
+ }
+
+ # add a new one
+ dbg("LRU $self->[5] cache add $call now $self->[4]/$self->[3]") if isdbg('lru');
+ $p = $self->new($ref, $call);
+ $self->add($p);
+ $self->obj->{$call} = $p;
+ $self->[4]++;
+ }
+}
+
+sub remove
+{
+ my ($self, $call) = @_;
+ my $q = $self->obj->{$call};
+ confess("$call is already removed") unless $q;
+ dbg("LRU $self->[5] cache remove $call now $self->[4]/$self->[3]") if isdbg('lru');
+ $q->obj(1);
+ $q->SUPER::del;
+ delete $self->obj->{$call};
+ $self->[4]--;
+}
+
+sub count
+{
+ return $_[0]->[4];
+}
+
+1;
use Data::Dumper;
use DXDebug;
use DXUtil;
-
+use LRU;
use strict;
$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
-#my $cachefn = "$main::data/prefix_cache";
+$lru = LRU->newbase('Prefix', $lrusize);
sub load
{
# untie every thing
-# unlink $cachefn;
-
if ($db) {
undef $db;
untie %pre;
%pre = ();
%prefix_loc = ();
- untie %cache;
}
# tie the main prefix database
do "$main::data/prefix_data.pl" if !$out;
$out = $@ if $@;
- # 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 store
$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;
+ $lru->put($_, \@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 = $misses = $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++;
$call =~ s/-\d+$//; # ignore SSIDs
- my $p = $cache{$call};
+ my $p = $lru->get($call);
my @nout;
if ($p) {
$hits++;
@nout = get($call);
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;
}
projects / spider.git / commitdiff