]> www.dxcluster.org Git - spider.git/blob - perl/LRU.pm
increase rbn connection startup delay
[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 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;