perl/LRU.pm

   1 #
   2 # A class implimenting LRU sematics with hash look up
   3 #
   4 # Copyright (c) 2002 Dirk Koopman, Tobit Computer Co Ltd
   5 #
   6 # $Id$
   7 #
   8 # The structure of the objects stored are:-
   9 #
  10 #  [next, prev, obj, callsign]
  11 #
  12 # The structure of the base is:-
  13 #
  14 #  [next, prev, max objects, count, <coderef to function to call on deletion> ]
  15 #
  16 #
  17
  18 package LRU;
  19
  20
  21 use strict;
  22 use Chain;
  23 use DXVars;
  24 use DXDebug;
  25
  26 use vars qw(@ISA);
  27 @ISA = qw(Chain);
  28
  29 use vars qw($VERSION $BRANCH);
  30 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  31 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  32 $main::build += $VERSION;
  33 $main::branch += $BRANCH;
  34
  35 sub newbase
  36 {
  37         my $pkg = shift;
  38         my $name = shift;
  39         my $max = shift;
  40         my $coderef = shift;
  41         confess "LRU->newbase requires a name and maximal count" unless $name && $max;
  42         return $pkg->SUPER::new({ }, $max, 0, $name, $coderef);
  43 }
  44
  45 sub get
  46 {
  47         my ($self, $call) = @_;
  48         if (my $p = $self->obj->{$call}) {
  49                 dbg("LRU $self->[5] cache hit $call") if isdbg('lru');
  50                 $self->rechain($p);
  51                 return $p->obj;
  52         }
  53         return undef;
  54 }
  55
  56 sub put
  57 {
  58         my ($self, $call, $ref) = @_;
  59         confess("need a call and a reference") unless defined $call && $ref;
  60         my $p = $self->obj->{$call};
  61         if ($p) {
  62                 # update the reference and rechain it
  63                 dbg("LRU $self->[5] cache update $call") if isdbg('lru');
  64                 $p->obj($ref);
  65                 $self->rechain($p);
  66         } else {
  67                 # delete one of the end of the chain if required
  68                 while ($self->[4] >= $self->[3] ) {
  69                         $p = $self->prev;
  70                         my $call = $p->[3];
  71                         dbg("LRU $self->[5] cache LRUed out $call now $self->[4]/$self->[3]") if isdbg('lru');
  72                         $self->remove($call);
  73                 }
  74
  75                 # add a new one
  76                 dbg("LRU $self->[5] cache add $call now $self->[4]/$self->[3]") if isdbg('lru');
  77                 $p = $self->new($ref, $call);
  78                 $self->add($p);
  79                 $self->obj->{$call} = $p;
  80                 $self->[4]++;
  81         }
  82 }
  83
  84 sub remove
  85 {
  86         my ($self, $call) = @_;
  87         my $q = $self->obj->{$call};
  88         confess("$call is already removed") unless $q;
  89         dbg("LRU $self->[5] cache remove $call now $self->[4]/$self->[3]") if isdbg('lru');
  90         &{$self->[5]}($q->obj) if $self->[5];
  91         $q->obj(1);
  92         $q->SUPER::del;
  93         delete $self->obj->{$call};
  94         $self->[4]--;
  95 }
  96
  97 sub count
  98 {
  99         return $_[0]->[4];
 100 }
 101
 102 1;