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 #
   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 ]
  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 constant OBJ => 2;
  30 use constant MAX => 3;
  31 use constant INUSE => 4;
  32 use constant NAME => 5;
  33 use constant CALLBACK => 6;
  34
  35 sub newbase
  36 {
  37         my $pkg = shift;
  38         my $name = shift;
  39         my $max = shift;
  40         my $callback = shift;
  41         confess "LRU->newbase requires a name and maximal count" unless $name && $max;
  42         return $pkg->SUPER::new({ }, $max, 0, $name, $callback);
  43 }
  44
  45 sub get
  46 {
  47         my ($self, $call) = @_;
  48         if (my $p = $self->obj->{$call}) {
  49                 dbg("LRU $self->[NAME] 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->[NAME] 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->[INUSE] >= $self->[MAX] ) {
  69                         $p = $self->prev;
  70                         my $call = $p->[MAX];
  71                         dbg("LRU $self->[NAME] cache LRUed out $call now $self->[INUSE]/$self->[MAX]") if isdbg('lru');
  72                         $self->remove($call);
  73                 }
  74
  75                 # add a new one
  76                 dbg("LRU $self->[NAME] cache add $call now $self->[INUSE]/$self->[MAX]") if isdbg('lru');
  77                 $p = $self->new($ref, $call);
  78                 $self->add($p);
  79                 $self->obj->{$call} = $p;
  80                 $self->[INUSE]++;
  81         }
  82 }
  83
  84 sub remove
  85 {
  86         my ($self, $call) = @_;
  87         my $p = $self->obj->{$call};
  88         confess("$call is already removed") unless $p;
  89         dbg("LRU $self->[NAME] cache remove $call now $self->[INUSE]/$self->[MAX]") if isdbg('lru');
  90         &{$self->[CALLBACK]}($p->obj) if $self->[CALLBACK];        # call back if required
  91         $p->obj(1);
  92         $p->SUPER::del;
  93         delete $self->obj->{$call};
  94         $self->[INUSE]--;
  95 }
  96
  97 sub count
  98 {
  99         return $_[0]->[INUSE];
 100 }
 101
 102 1;