File Coverage

blib/lib/Tie/Cache/LRU/LinkedList.pm
Criterion Covered Total %
statement 116 136 85.2
branch 23 36 63.8
condition 6 10 60.0
subroutine 19 21 90.4
pod 2 2 100.0
total 166 205 80.9


line stmt bran cond sub pod time code
1             package Tie::Cache::LRU::LinkedList;
2              
3 2     2   1537 use strict;
  2         3  
  2         80  
4              
5 2     2   950 use Carp::Assert;
  2         1231  
  2         20  
6              
7 2     2   289 use base qw(Tie::Cache::LRU::Virtual);
  2         4  
  2         611  
8              
9 2     2   82 use constant SUCCESS => 1;
  2         4  
  2         142  
10 2     2   10 use constant FAILURE => 0;
  2         4  
  2         92  
11              
12             # Node members.
13 2     2   754 use enum qw(KEY VALUE PREV NEXT);
  2         1273  
  2         14  
14              
15              
16             =pod
17              
18             =head1 NAME
19              
20             Tie::Cache::LRU::LinkedList - Tie::Cache::LRU implemented using a linked list
21              
22             =head1 SYNOPSIS
23              
24             use Tie::Cache::LRU::LinkedList;
25              
26             tie %cache, 'Tie::Cache::LRU', 500;
27              
28             ...the rest is as Tie::Cache::LRU...
29              
30             =head1 DESCRIPTION
31              
32             This is an implementation of Tie::Cache::LRU using a linked list
33             structure. Theoretically, this is an efficient algorithm, however it
34             may be lose out in smaller cache sizes (where small <= ??) due to its
35             relatively high constant.
36              
37             =cut
38              
39             sub TIEHASH {
40 1     1   12 my($class, $max_size) = @_;
41 1         4 my $self = bless {}, $class;
42              
43 1 50       6 $max_size = $class->DEFAULT_MAX_SIZE unless defined $max_size;
44              
45 1         5 $self->_init;
46 1         4 $self->max_size($max_size);
47              
48 1         3 return $self;
49             }
50              
51              
52             sub FETCH {
53 4     4   9 my($self, $key) = @_;
54              
55 4 50       12 return unless $self->EXISTS($key);
56              
57 4         10 my $node = $self->{index}{$key};
58 4         11 $self->_promote($node);
59 4         13 return $node->[VALUE];
60             }
61              
62              
63             sub STORE {
64 2     2   22 my($self, $key, $value) = @_;
65              
66 2 50       5 if( $self->EXISTS($key) ) {
67 0         0 my $node = $self->{index}{$key};
68 0         0 $node->[VALUE] = $value;
69 0         0 $self->_promote($node);
70             }
71             else {
72 2         4 my $node = [];
73 2         3 @{$node}[KEY, VALUE] = ($key, $value);
  2         8  
74              
75             ### Might it be smarter to just attach the new node to the list
76             ### and call _promote()?
77             # Make ourselves the freshest.
78 2 100       7 if(defined $self->{freshest} ) {
79 1         10 $self->{freshest}->[NEXT] = $node;
80 1         4 $node->[PREV] = $self->{freshest};
81             }
82             else {
83 1         4 assert($self->{size} == 0);
84             }
85 2         8 $self->{freshest} = $node;
86            
87             # If we're the first node, we are stinky, too.
88 2 100       7 unless( defined $self->{stinkiest} ) {
89 1         3 assert($self->{size} == 0);
90 1         5 $self->{stinkiest} = $node;
91             }
92 2         2 $self->{size}++;
93 2         5 $self->{index}{$key} = $node;
94 2         6 $self->_cull;
95             }
96 2         8 return SUCCESS;
97             }
98              
99              
100             sub EXISTS {
101 8     8   12 my($self, $key) = @_;
102              
103 8         44 return exists $self->{index}{$key};
104             }
105              
106              
107             sub CLEAR {
108 0     0   0 my($self) = @_;
109 0         0 $self->_init;
110             }
111              
112              
113             sub DELETE {
114 2     2   16 my($self, $key) = @_;
115              
116 2 50       5 return unless $self->EXISTS($key);
117              
118 2         4 my $node = $self->{index}{$key};
119 2 50       9 $self->{freshest} = $node->[PREV] if $self->{freshest} == $node;
120 2 100       8 $self->{stinkiest} = $node->[NEXT] if $self->{stinkiest} == $node;
121 2         7 $self->_yank($node);
122 2         5 delete $self->{index}{$key};
123            
124 2         4 $self->{size}--;
125            
126 2         15 return $node->[VALUE];
127             }
128              
129              
130             # keys() should return most to least recent.
131             sub FIRSTKEY {
132 3     3   1321 my($self) = shift;
133 3         7 my $node = $self->{freshest};
134 3   50     31 assert($self->{size} == 0 xor defined $node);
135              
136 3         12 my @nodes;
137 3         4 do {
138 5         10 push @nodes, $node;
139 5         25 $node = $node->[PREV];
140             } while defined $node;
141              
142 3         7 $self->{nodes} = \@nodes;
143 3         11 $self->NEXTKEY();
144             }
145              
146             sub NEXTKEY {
147 7     7   23 my $self = shift;
148 7         45 my $node = shift @{$self->{nodes}};
  7         16  
149 7         37 return $node->[KEY];
150             }
151              
152              
153             sub DESTROY {
154 1     1   463 my($self) = shift;
155              
156             # The chain must be broken.
157 1         4 $self->_init;
158            
159 1         6 return SUCCESS;
160             }
161              
162              
163             sub max_size {
164 3     3 1 6 my($self) = shift;
165              
166 3 100       7 if(@_) {
167 1         2 my ($new_max_size) = shift;
168 1   33     11 assert(defined $new_max_size && $new_max_size !~ /\D/);
169 1         5 $self->{max_size} = $new_max_size;
170              
171             # Immediately purge the cache if necessary.
172 1 50       11 $self->_cull if $self->{size} > $new_max_size;
173              
174 1         3 return SUCCESS;
175             }
176             else {
177 2         6 return $self->{max_size};
178             }
179             }
180              
181              
182             sub curr_size {
183 0     0 1 0 my($self) = shift;
184              
185             # We brook no arguments.
186 0         0 assert(!@_);
187              
188 0         0 return $self->{size};
189             }
190              
191              
192             sub _init {
193 2     2   5 my($self) = shift;
194              
195             # The cache is a chain. We must break up its structure so Perl
196             # can GC it.
197 2         5 while( my($key, $node) = each %{$self->{index}} ) {
  2         22  
198 0         0 $node->[NEXT] = undef;
199 0         0 $node->[PREV] = undef;
200             }
201              
202 2         6 $self->{freshest} = undef;
203 2         6 $self->{stinkiest} = undef;
204 2         6 $self->{index} = {};
205 2         6 $self->{size} = 0;
206 2         5 $self->{nodes} = [];
207              
208 2         4 return SUCCESS;
209             }
210              
211              
212             sub _yank {
213 3     3   4 my($self, $node) = @_;
214            
215 3         7 my $prev_node = $node->[PREV];
216 3         13 my $next_node = $node->[NEXT];
217 3 100       10 $prev_node->[NEXT] = $next_node if defined $prev_node;
218 3 100       7 $next_node->[PREV] = $prev_node if defined $next_node;
219              
220 3         6 $node->[NEXT] = undef;
221 3         6 $node->[PREV] = undef;
222              
223 3         4 return SUCCESS;
224             }
225              
226              
227             sub _promote {
228 4     4   7 my($self, $node) = @_;
229              
230             # _promote can take a node or a key. Get the node from the key.
231 4 50       10 $node = $self->{index}{$node} unless ref $node;
232 4 50       10 return unless defined $node;
233              
234             # Don't bother if there's only one node, or if this node is
235             # already the freshest.
236 4 100 100     37 return if $self->{size} == 1 or $self->{freshest} == $node;
237              
238             # On the off chance that we're about to promote the stinkiest node,
239             # make sure the stinkiest pointer is updated.
240 1 50       5 if( $self->{stinkiest} == $node ) {
241 1         4 assert(not defined $node->[PREV]);
242 1         5 $self->{stinkiest} = $node->[NEXT];
243             }
244              
245             # Pull the $node out of its position.
246 1         5 $self->_yank($node);
247              
248             # Place the $node at the head.
249 1         2 my $old_head = $self->{freshest};
250 1         2 $old_head->[NEXT] = $node;
251 1         3 $node->[PREV] = $old_head;
252 1         2 $node->[NEXT] = undef;
253              
254 1         2 $self->{freshest} = $node;
255              
256 1         2 return SUCCESS;
257             }
258              
259              
260             sub _cull {
261 2     2   3 my($self) = @_;
262            
263 2         5 my $max_size = $self->max_size;
264              
265 2         8 for( ;$self->{size} > $max_size; $self->{size}-- ) {
266 0         0 my $rotten = $self->{stinkiest};
267 0         0 assert(!defined $rotten->[PREV]);
268 0         0 my $new_stink = $rotten->[NEXT];
269            
270 0         0 $rotten->[NEXT] = undef;
271            
272             # Gotta watch out for autoviv.
273 0 0       0 $new_stink->[PREV] = undef if defined $new_stink;
274            
275 0         0 $self->{stinkiest} = $new_stink;
276 0 0       0 if( $self->{freshest} eq $rotten ) {
277 0         0 assert( $self->{size} == 1 ) if DEBUG;
278 0         0 $self->{freshest} = $new_stink;
279             }
280              
281 0         0 delete $self->{index}{$rotten->[KEY]};
282             }
283            
284 2         5 return SUCCESS;
285             }
286              
287              
288             =pod
289              
290             =head1 AUTHOR
291              
292             Michael G Schwern
293              
294             =head1 SEE ALSO
295              
296             L, L,
297             L, L
298              
299             =cut
300              
301             1;
302