]> scm.dxcluster.org Git - spider.git/blob - perl/LRU.pm
lose some of the annoying uninitialised msgs
[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 #
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;