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 sub newbase
  30 {
  31         my $pkg = shift;
  32         my $name = shift;
  33         my $max = shift;
  34         confess "LRU->newbase requires a name and maximal count" unless $name && $max;
  35         return $pkg->SUPER::new({ }, $max, 0, $name);
  36 }
  37
  38 sub get
  39 {
  40         my ($self, $call) = @_;
  41         if (my $p = $self->obj->{$call}) {
  42                 dbg("LRU $self->[5] cache hit $call") if isdbg('lru');
  43                 $self->rechain($p);
  44                 return $p->obj;
  45         }
  46         return undef;
  47 }
  48
  49 sub put
  50 {
  51         my ($self, $call, $ref) = @_;
  52         confess("need a call and a reference") unless defined $call && $ref;
  53         my $p = $self->obj->{$call};
  54         if ($p) {
  55                 # update the reference and rechain it
  56                 dbg("LRU $self->[5] cache update $call") if isdbg('lru');
  57                 $p->obj($ref);
  58                 $self->rechain($p);
  59         } else {
  60                 # delete one of the end of the chain if required
  61                 while ($self->[4] >= $self->[3] ) {
  62                         $p = $self->prev;
  63                         my $call = $p->[3];
  64                         dbg("LRU $self->[5] cache LRUed out $call now $self->[4]/$self->[3]") if isdbg('lru');
  65                         $self->remove($call);
  66                 }
  67
  68                 # add a new one
  69                 dbg("LRU $self->[5] cache add $call now $self->[4]/$self->[3]") if isdbg('lru');
  70                 $p = $self->new($ref, $call);
  71                 $self->add($p);
  72                 $self->obj->{$call} = $p;
  73                 $self->[4]++;
  74         }
  75 }
  76
  77 sub remove
  78 {
  79         my ($self, $call) = @_;
  80         my $q = $self->obj->{$call};
  81         confess("$call is already removed") unless $q;
  82         dbg("LRU $self->[5] cache remove $call now $self->[4]/$self->[3]") if isdbg('lru');
  83         $q->obj(1);
  84         $q->SUPER::del;
  85         delete $self->obj->{$call};
  86         $self->[4]--;
  87 }
  88
  89 sub count
  90 {
  91         return $_[0]->[4];
  92 }
  93
  94 1;