X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=perl%2FLRU.pm;fp=perl%2FLRU.pm;h=d53b115b55e2a52d417987a69802362c5238e3b1;hb=f87323c2926605792ee02b84783d8f3d4dbd605f;hp=0000000000000000000000000000000000000000;hpb=bf0078cc89a908d46a3f28c7f1c152c2cb4d6fc5;p=spider.git

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;