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