]> gb7djk.dxcluster.net Git - spider.git/blob - perl/LRU.pm
a pretty nearly working gtkconsole...
[spider.git] / 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;