add LRU caching

[spider.git] / perl / LRU.pm

diff --git a/perl/LRU.pm b/perl/LRU.pm
new file mode 100644 (file)
index 0000000..d53b115
--- /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;