File Coverage

blib/lib/Cache/Tester.pm
Criterion Covered Total %
statement 286 292 97.9
branch 7 14 50.0
condition 1 3 33.3
subroutine 29 32 90.6
pod 0 17 0.0
total 323 358 90.2


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Cache::Tester - test utility for Cache implementations
4              
5             =head1 SYNOPSIS
6              
7             use Cache::Tester;
8              
9             BEGIN { plan tests => 2 + $CACHE_TESTS }
10              
11             use_ok('Cache::Memory');
12              
13             my $cache = Cache::Memory->new();
14             ok($cache, 'Cache created');
15              
16             run_cache_tests($cache);
17              
18             =head1 DESCRIPTION
19              
20             This module is used to run tests against an instance of a Cache implementation
21             to ensure that it operates as required by the Cache specification.
22              
23             =cut
24             package Cache::Tester;
25              
26             require 5.006;
27 3     3   1653 use strict;
  3         3  
  3         90  
28 3     3   10 use warnings;
  3         4  
  3         57  
29 3     3   1277 use Test::More;
  3         31108  
  3         25  
30 3     3   819 use Exporter;
  3         5  
  3         119  
31 3     3   12 use vars qw(@ISA @EXPORT $VERSION $CACHE_TESTS);
  3         4  
  3         167  
32 3     3   19 use Carp;
  3         4  
  3         3586  
33              
34             @ISA = qw(Exporter Test::More);
35             $VERSION = '2.11';
36             @EXPORT = (qw(run_cache_tests $CACHE_TESTS), @Test::More::EXPORT);
37              
38             $CACHE_TESTS = 79;
39              
40             sub run_cache_tests {
41 1     1 0 265 my ($cache) = @_;
42              
43 1 50       4 $cache or croak "Cache required";
44              
45 1         4 test_store_scalar($cache);
46 1         4 test_entry_size($cache);
47 1         4 test_store_complex($cache);
48 1         3 test_cache_size($cache);
49 1         335 test_cache_count($cache);
50 1         384 test_expiry($cache);
51 1         7 test_read_handle($cache);
52 1         4 test_write_handle($cache);
53 1         4 test_append_handle($cache);
54 1         3 test_handle_async_read($cache);
55 1         4 test_handle_async_remove($cache);
56 1         4 test_handle_async_replace($cache);
57 1         4 test_validity($cache);
58 1         8 test_load_callback($cache);
59 1         6 test_validate_callback($cache);
60             }
61              
62             # Test storing, retrieving and removing simple scalars
63             sub test_store_scalar {
64 1     1 0 1 my ($cache) = @_;
65              
66 1         2 my $key = 'testkey';
67 1         4 my $entry = $cache->entry($key);
68 1         4 _ok($entry, 'entry returned');
69 1         219 _is($entry->key(), $key, 'entry key correct');
70 1         266 _ok(!$entry->exists(), 'entry doesn\'t exist initially');
71 1         215 _is($entry->get(), undef, '$entry->get() returns undef');
72              
73 1         218 $entry->set('test data');
74 1         7 _ok($entry->exists(), 'entry exists');
75 1         349 _is($entry->get(), 'test data', 'set/get worked');
76              
77 1         217 $entry->remove();
78 1         4 _ok(!$entry->exists(), 'entry removed');
79              
80 1         395 $cache->set($key, 'more test data');
81 1         8 _ok($cache->exists($key), 'key exists');
82 1         216 _is($cache->get($key), 'more test data', 'cache set/get worked');
83              
84 1         255 $cache->remove($key);
85 1         4 _ok(!$entry->exists(), 'entry removed via cache');
86             }
87              
88             # Test size reporting of entries
89             sub test_entry_size {
90 1     1 0 1 my ($cache) = @_;
91              
92 1         3 my $entry = $cache->entry('testsize');
93 1         5 $entry->set('A'x1234);
94 1         7 _ok($entry->exists(), 'entry created');
95 1         222 _is($entry->size(), 1234, 'entry size is correct');
96              
97 1         268 $entry->remove();
98             }
99              
100             # Test storing of complex entities
101             sub test_store_complex {
102 1     1 0 1 my ($cache) = @_;
103              
104 1         4 my @array = (1, 2, { hi => 'there' });
105              
106 1         4 my $entry = $cache->entry('testcomplex');
107 1         7 $entry->freeze(\@array);
108 1         8 _ok($entry->exists(), 'frozen entry created');
109 1         220 my $arrayref = $entry->thaw();
110 1   33     52 _ok($array[0] == $$arrayref[0] &&
111             $array[1] == $$arrayref[1] &&
112             $array[2]->{hi} eq $$arrayref[2]->{hi}, 'entry thawed');
113              
114 1         218 $entry->remove();
115             }
116              
117             # Test size tracking of cache
118             sub test_cache_size {
119 1     1 0 2 my ($cache) = @_;
120              
121 1         3 $cache->clear();
122 1         3 _is($cache->size(), 0, 'cache is empty after clear');
123 1         217 $cache->set('testkey', 'A'x4000);
124 1         7 _is($cache->size(), 4000, 'cache size is correct after set');
125 1         292 $cache->set('testkey2', 'B'x200);
126 1         9 _is($cache->size(), 4200, 'cache size is correct after 2 sets');
127 1         220 $cache->set('testkey', 'C'x2800);
128 1         8 _is($cache->size(), 3000, 'cache size is correct after replace');
129 1         215 $cache->remove('testkey2');
130 1         48 _is($cache->size(), 2800, 'cache size is correct after remove');
131              
132 1         214 $cache->clear();
133 1         4 _is($cache->size(), 0, 'cache is empty after clear');
134              
135             # Add 100 entries of various lengths
136 1         214 my $size = 0;
137 1         9 my @keys = (1..100);
138 1         2 foreach (@keys) {
139 100         350 $cache->set("key$_", "D"x$_);
140 100         663 $size += $_;
141             }
142 1         3 _is($cache->size(), $size, 'cache size is ok after multiple sets');
143              
144 1         313 shuffle(\@keys);
145 1         3 foreach (@keys) {
146 100         260 $cache->remove("key$_");
147             }
148 1         4 _is($cache->size(), 0, 'cache is empty after multiple removes');
149             }
150              
151             # Test count tracking of cache
152             sub test_cache_count {
153 1     1 0 3 my ($cache) = @_;
154              
155 1         5 $cache->clear();
156 1         31 _is($cache->count(), 0, 'cache is empty after clear');
157 1         196 $cache->set('testkey', 'test');
158 1         11 _is($cache->count(), 1, 'cache count correct after set');
159 1         215 $cache->set('testkey2', 'test2');
160 1         6 _is($cache->count(), 2, 'cache count correct after 2 sets');
161 1         216 $cache->set('testkey', 'test3');
162 1         7 _is($cache->count(), 2, 'cache count correct after replace');
163 1         217 $cache->remove('testkey2');
164 1         4 _is($cache->count(), 1, 'cache count correct after remove');
165              
166 1         216 $cache->clear();
167 1         5 _is($cache->count(), 0, 'cache is empty after clear');
168              
169             # Add 100 entries
170 1         249 my @keys = (1..100);
171 1         4 foreach (@keys) {
172 100         307 $cache->set("key$_", "test");
173             }
174 1         4 _is($cache->count(), 100, 'cache count correct after multiple sets');
175              
176 1         314 shuffle(\@keys);
177 1         2 foreach(@keys) {
178 100         238 $cache->remove("key$_");
179             }
180 1         6 _is($cache->size(), 0, 'cache empty after multiple removes');
181             }
182              
183             # Test expiry
184             sub test_expiry {
185 1     1 0 3 my ($cache) = @_;
186              
187 1         5 my $entry = $cache->entry('testexp');
188              
189 1         5 $entry->set('test data');
190 1         15 $entry->set_expiry('100 minutes');
191 1         4 _cmp_ok($entry->expiry(), '>', time(), 'expiry set correctly');
192 1         223 _cmp_ok($entry->expiry(), '<=', time() + 100*60, 'expiry set correctly');
193 1         216 $entry->remove();
194              
195 1         3 my $size = $cache->size();
196              
197 1         4 $entry->set('test data', 'now');
198 1         3 _ok(!$entry->exists(), 'entry set with instant expiry not added');
199 1         216 _is($cache->size(), $size, 'size is unchanged');
200              
201             # This is to fix/workaround the test failures by high load. See:
202             # https://rt.cpan.org/Public/Bug/Display.html?id=27280
203 1 50       218 my $delay = $ENV{PERL_CACHE_PM_TESTING} ? 1 : 3;
204 1         5 $entry->set('test data', "$delay sec");
205 1         4 _ok($entry->exists(), "entry with $delay sec timeout added");
206 1         4000368 sleep($delay+1);
207 1         28 _ok(!$entry->exists(), 'entry expired');
208 1         477 _is($cache->size(), $size, 'size is unchanged');
209              
210 1         293 $entry->set('test data', '1 minute');
211 1         6 _ok($entry->exists(), 'entry with 1 min timeout added');
212 1         2000425 sleep(2);
213 1         22 _ok($entry->exists(), 'entry with 1 min timeout remains');
214 1         395 $entry->set_expiry('now');
215 1         4 _ok(!$entry->exists(), 'entry expired after change to instant timeout');
216 1         204 _is($cache->size(), $size, 'size is unchanged');
217             }
218              
219             # Test reading via a handle
220             sub test_read_handle {
221 1     1 0 3 my ($cache) = @_;
222              
223 1         8 my $entry = $cache->entry('readhandle');
224 1         4 $entry->remove();
225 1         27 my $handle = $entry->handle('<');
226 1         4 _ok(!$handle, 'read handle not available for empty entry');
227              
228 1         511 $entry->set('some test data');
229              
230 1         9 $handle = $entry->handle('<');
231 1         6 _ok($handle, 'read handle created');
232 1 50       321 $handle or diag("handle not created: $!");
233              
234 1         4 local $/;
235 1         7 _is(<$handle>, 'some test data', 'read via <$handle> successful');
236              
237             {
238 3     3   17 no warnings;
  3         5  
  3         3803  
  1         300  
239 1         8 print $handle 'this wont work';
240             }
241 1         5 $handle->close();
242 1         8 _is($entry->get(), 'some test data', 'write to read only handle failed');
243              
244 1         370 $entry->remove();
245             }
246              
247             # Test writing via a handle
248             sub test_write_handle {
249 1     1 0 1 my ($cache) = @_;
250              
251 1         3 my $entry = $cache->entry('writehandle');
252 1         3 $entry->remove();
253              
254 1         4 my $size = $cache->size();
255              
256 1         3 my $handle = $entry->handle('>');
257 1         5 _ok($handle, 'write handle created');
258 1 50       328 $handle or diag("handle not created: $!");
259              
260 1         5 print $handle 'A'x100;
261 1         13 $handle->close();
262              
263 1         12 _is($entry->get(), 'A'x100, 'write to write only handle ok');
264 1         415 _is($entry->size(), 100, 'entry size is correct');
265 1         445 _is($cache->size(), $size + 100, 'cache size is correct');
266              
267 1         312 $entry->remove();
268             }
269              
270             # Test append via a handle
271             sub test_append_handle {
272 1     1 0 3 my ($cache) = @_;
273              
274 1         5 my $entry = $cache->entry('appendhandle');
275 1         3 $entry->remove();
276 1         4 $entry->set('hello ');
277              
278 1         7 my $size = $cache->size();
279              
280 1         9 my $handle = $entry->handle('>>');
281 1         9 _ok($handle, 'append handle created');
282 1 50       408 $handle or diag("handle not created: $!");
283              
284 1         7 $handle->print('world');
285 1         12 $handle->close();
286              
287 1         8 _is($entry->get(), 'hello world', 'write to append handle ok');
288 1         350 _is($entry->size(), 11, 'entry size is correct');
289 1         346 _is($entry->size(), $size + 5, 'cache size is correct');
290              
291 1         306 $entry->remove();
292             }
293              
294             # Test that a entry can be read while a handle is open for read
295             sub test_handle_async_read {
296 1     1 0 2 my ($cache) = @_;
297              
298 1         3 my $entry = $cache->entry('readhandle');
299 1         3 $entry->remove();
300              
301 1         2 my $size = $cache->size();
302              
303 1         1 my $data = 'test data';
304 1         4 $entry->set($data);
305              
306 1 50       8 my $handle = $entry->handle('<') or diag("handle not created: $!");
307              
308 1         8 _ok($entry->exists(), 'entry exists after handle opened');
309 1         445 _is(<$handle>, $data, 'handle returns correct data');
310 1         438 _is($entry->get(), $data, '$entry->get() returns correct data');
311 1         369 $handle->close();
312 1         8 _ok($entry->exists(), 'entry exists after handle closed');
313 1         499 _is($entry->get(), $data, '$entry->get() returns correct data');
314             }
315              
316             # Test that a handle can be removed asynchronously with it being open
317             sub test_handle_async_remove {
318 1     1 0 2 my ($cache) = @_;
319              
320 1         3 my $entry = $cache->entry('removehandle');
321 1         4 $entry->remove();
322              
323 1         3 my $size = $cache->size();
324              
325 1         4 $entry->set('test data');
326              
327 1 50       8 my $handle = $entry->handle() or diag("handle not created: $!");
328              
329             # extend data by 5 bytes before removing the entry
330 1         7 $handle->print('some more data');
331 1         12 $handle->seek(0,0);
332              
333 1         12 $entry->remove();
334 1         3 _ok(!$entry->exists(), 'entry removed whilst handle active');
335              
336 1         513 local $/;
337 1         5 _is(<$handle>, 'some more data', 'read via <$handle> successful');
338              
339             # ensure we can still write to the handle
340 1         389 $handle->seek(0,0);
341 1         13 $handle->print('hello wide wide world');
342 1         11 $handle->seek(0,0);
343 1         10 _is(<$handle>, 'hello wide wide world', 'write via <$handle> successful');
344              
345 1         356 $handle->close();
346 1         8 _ok(!$entry->exists(), 'entry still removed after handle closed');
347 1         353 _is($entry->size(), undef, 'entry size is undefined');
348 1         372 _is($cache->size(), $size, 'cache size is correct');
349             }
350              
351             sub test_handle_async_replace {
352 1     1 0 2 my ($cache) = @_;
353              
354 1         3 my $entry = $cache->entry('replacehandle');
355 1         4 $entry->remove();
356              
357 1         3 my $size = $cache->size();
358              
359 1         3 $entry->set('test data');
360              
361 1         8 my $handle = $entry->handle();
362              
363 1         7 $entry->set('A'x20);
364 1         7 _is($entry->get(), 'A'x20, 'entry replaced whilst handle active');
365              
366 1         459 local $/;
367 1         3 _is(<$handle>, 'test data', 'read via <$handle> successful');
368 1         364 $handle->seek(0,0);
369 1         13 $handle->print('hello world');
370 1         10 $handle->seek(0,0);
371 1         10 _is(<$handle>, 'hello world', 'write via <$handle> successful');
372              
373 1         352 $handle->close();
374 1         7 _ok($entry->exists(), 'entry still exists after handle closed');
375 1         298 _is($entry->get(), 'A'x20, 'entry still correct after handle closed');
376 1         368 _is($entry->size(), 20, 'entry size is correct');
377 1         373 _is($cache->size(), $size+20, 'cache size is correct');
378             }
379              
380             sub test_validity {
381 1     1 0 3 my ($cache) = @_;
382              
383 1         2 my $entry = $cache->entry('validityentry');
384 1         3 $entry->remove();
385              
386             # create an entry with validity
387 1         2 $entry->set('test data');
388 1         10 $entry->set_validity({ tester => 'test string' });
389              
390 1         2 undef $entry;
391 1         2 $entry = $cache->entry('validityentry');
392 1         3 my $validity = $entry->validity();
393 1         2 _ok($validity, 'validity retrieved');
394 1         363 _is($validity->{tester}, 'test string', 'validity correct');
395              
396 1         483 $entry->remove();
397              
398             # create an entry with only validity
399 1         5 $entry->set_validity({ tester => 'test string' });
400              
401 1         2 undef $entry;
402 1         3 $entry = $cache->entry('validityentry');
403 1         4 $validity = $entry->validity();
404 1         4 _ok($validity, 'validity retrieved');
405 1         336 _is($validity->{tester}, 'test string', 'validity correct');
406              
407 1         300 $entry->remove();
408              
409             # create an entry with scalar validity
410 1         5 $entry->set('test data');
411 1         7 $entry->set_validity('test string');
412              
413 1         2 undef $entry;
414 1         2 $entry = $cache->entry('validityentry');
415 1         3 $validity = $entry->validity();
416 1         3 _ok($validity, 'validity retrieved');
417 1         349 _is($validity, 'test string', 'validity correct');
418             }
419              
420             sub test_load_callback {
421 1     1 0 3 my ($cache) = @_;
422              
423 1         2 my $key = 'testloadcallback';
424 1         4 $cache->remove($key);
425              
426 1         10 my $old_callback = $cache->load_callback();
427 1     1   8 $cache->set_load_callback(sub { return "result ".$_[0]->key() });
  1         6  
428              
429 1         5 _ok($cache->get($key), "result $key");
430 1         497 $cache->set_load_callback($old_callback);
431             }
432              
433             sub test_validate_callback {
434 1     1 0 2 my ($cache) = @_;
435              
436 1         2 my $key = 'testvalidatecallback';
437 1         1 my $result;
438 1         9 my $old_callback = $cache->validate_callback();
439 1     1   8 $cache->set_validate_callback(sub { $result = "result ".$_[0]->key() });
  1         5  
440              
441 1         5 $cache->set($key, 'somedata');
442 1         9 $cache->get($key);
443 1         3 _is($result, "result $key", "validate_callback ok");
444 1         463 $cache->set_validate_callback($old_callback);
445             }
446              
447              
448             ### Wrappers for test methods to add function name
449              
450             sub _ok ($$) {
451 28     28   43 my($test, $name) = @_;
452 28         261 ok($test, (caller(1))[3].': '.$name);
453             }
454              
455             sub _is ($$$) {
456 49     49   117 my($x, $y, $name) = @_;
457 49         407 is($x, $y, (caller(1))[3].': '.$name);
458             }
459              
460             sub _isnt ($$$) {
461 0     0   0 my($x, $y, $name) = @_;
462 0         0 isnt($x, $y, (caller(1))[3].': '.$name);
463             }
464              
465             sub _like ($$$) {
466 0     0   0 my($x, $y, $name) = @_;
467 0         0 like($x, $y, (caller(1))[3].': '.$name);
468             }
469              
470             sub _unlike ($$$) {
471 0     0   0 my($x, $y, $name) = @_;
472 0         0 unlike($x, $y, (caller(1))[3].': '.$name);
473             }
474              
475             sub _cmp_ok ($$$$) {
476 2     2   3 my ($x, $c, $y, $name) = @_;
477 2         18 cmp_ok($x, $c, $y, (caller(1))[3].': '.$name);
478             }
479              
480              
481             # Taken from perlfaq4
482             sub shuffle {
483 2     2 0 5 my $deck = shift; # $deck is a reference to an array
484 2         4 my $i = @$deck;
485 2         10 while ($i--) {
486 200         272 my $j = int rand ($i+1);
487 200         463 @$deck[$i,$j] = @$deck[$j,$i];
488             }
489             }
490              
491              
492             1;
493             __END__