From: minima <minima>
Date: Sun, 29 Sep 2002 17:28:32 +0000 (+0000)
Subject: add LRU caching
X-Git-Tag: PRE-1-52~180
X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=f87323c2926605792ee02b84783d8f3d4dbd605f;p=spider.git

add LRU caching
---

diff --git a/Changes b/Changes
index 069f8e16..bb4f33df 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,5 @@
+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.
diff --git a/perl/Chain.pm b/perl/Chain.pm
index cb3a2be8..8afd62f0 100644
--- a/perl/Chain.pm
+++ b/perl/Chain.pm
@@ -30,10 +30,11 @@ sub setcheck
 # 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;
 }
 
@@ -44,7 +45,7 @@ sub ins
 	
 	$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;
@@ -68,9 +69,10 @@ sub del
 	
 	$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?
@@ -104,7 +106,7 @@ sub prev
 	
 	$docheck && _check($base);
 	
-	return $base->[NEXT] == $base ? undef : $base->[PREV] unless $p; 
+	return $base->[PREV] == $base ? undef : $base->[PREV] unless $p; 
 	
 	$docheck && _check($p);
 	
@@ -161,9 +163,9 @@ Chain - Double linked circular chain handler
 =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);
diff --git a/perl/DXProt.pm b/perl/DXProt.pm
index 2168c7fc..9a4f3673 100644
--- a/perl/DXProt.pm
+++ b/perl/DXProt.pm
@@ -1078,7 +1078,7 @@ sub normal
 
 			# 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]);
diff --git a/perl/DXUser.pm b/perl/DXUser.pm
index 690a8ae4..80a9b641 100644
--- a/perl/DXUser.pm
+++ b/perl/DXUser.pm
@@ -15,6 +15,7 @@ use Fcntl;
 use IO::File;
 use DXDebug;
 use DXUtil;
+use LRU;
 
 use strict;
 
@@ -24,13 +25,14 @@ $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0))
 $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 = (
@@ -121,6 +123,7 @@ sub init
 	}
 	
 	$filename = $fn;
+	$lru = LRU->newbase("DXUser", $lrusize);
 }
 
 sub del_file
@@ -182,8 +185,16 @@ sub get
 	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;
 }
@@ -233,7 +244,9 @@ sub put
 	$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);
 }
 
 # 
@@ -277,6 +290,7 @@ sub del
 #	for ($dbm->get_dup($call)) {
 #		$dbm->del_dup($call, $_);
 #	}
+	$lru->remove($call);
 	$dbm->del($call);
 }
 
diff --git a/perl/LRU.pm b/perl/LRU.pm
new file mode 100644
index 00000000..d53b115b
--- /dev/null
+++ b/perl/LRU.pm
@@ -0,0 +1,100 @@
+#
+# 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;
diff --git a/perl/Prefix.pm b/perl/Prefix.pm
index a2316a2b..a07ebdbd 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,28 +24,24 @@ $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
 
-#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
@@ -54,9 +50,7 @@ sub load
 	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
@@ -152,14 +146,14 @@ sub matchprefix
 		$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++;
@@ -170,7 +164,7 @@ sub matchprefix
 				dbg("Partial prefix: $pref $s $part" );
 			} 
 			if (@out && $out[0] eq $s) {
-				$cache{$_} =  \@out for @partials;
+				$lru->put($_, \@out) for @partials;
 				return @out;
 			} 
 		}
@@ -194,24 +188,13 @@ sub extract
 	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++;
@@ -225,7 +208,7 @@ LM:	foreach $call (split /,/, $calls) {
 			@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;
@@ -246,7 +229,7 @@ LM:	foreach $call (split /,/, $calls) {
 			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;
 			}
@@ -266,7 +249,7 @@ LM:	foreach $call (split /,/, $calls) {
 				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;
 				}
@@ -289,7 +272,7 @@ LM:	foreach $call (split /,/, $calls) {
 				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;
 				}
@@ -305,7 +288,7 @@ LM:	foreach $call (split /,/, $calls) {
 			if (@nout) {
 				dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
 				$misses++;
-				$cache{$call} = \@nout;
+				$lru->put($call, \@nout);
 				push @out, @nout;
 				next;
 			}
@@ -350,16 +333,16 @@ L1:		for ($n = 0; $n < @parts; $n++) {
 					}
 					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;
@@ -369,7 +352,7 @@ L1:		for ($n = 0; $n < @parts; $n++) {
 		# we are a pirate!
 		@nout = matchprefix('Q');
 		$misses++;
-		$cache{$call} = \@nout;
+		$lru->put($call, \@nout);
 		push @out, @nout;
 	}