File Coverage

blib/lib/Cache/CacheTester.pm

Criterion	Covered	Total	%
statement	229	256	89.5
branch	44	94	46.8
condition	4	12	33.3
subroutine	27	29	93.1
pod	1	2	50.0
total	305	393	77.6

line	stmt	bran	cond	sub	pod	time	code
1							######################################################################
2							# $Id: CacheTester.pm,v 1.21 2003/04/15 14:46:17 dclinton Exp $
3							# Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved
4							#
5							# Software distributed under the License is distributed on an "AS
6							# IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or
7							# implied. See the License for the specific language governing
8							# rights and limitations under the License.
9							######################################################################
10
11							package Cache::CacheTester;
12
13	4			4		61	use strict;
	4					57
	4					116
14	4			4		197	use Cache::BaseCacheTester;
	4					40
	4					81
15	4			4		84	use Cache::Cache;
	4					95
	4					127
16	4			4		105	use Error qw( :try );
	4					41
	4					64
17
18	4			4		67	use vars qw( @ISA $EXPIRES_DELAY );
	4					37
	4					56
19
20							@ISA = qw ( Cache::BaseCacheTester );
21
22							$EXPIRES_DELAY = 2;
23							$Error::Debug = 1;
24
25							sub test
26							{
27	4			4	1	80	my ( $self, $cache ) = @_;
28
29							try
30							{
31	4			4		90	$cache->Clear( );
32	4					62	$self->_test_one( $cache );
33	4					58	$self->_test_two( $cache );
34	4					53	$self->_test_three( $cache );
35	4					52	$self->_test_four( $cache );
36	4					55	$self->_test_five( $cache );
37	4					56	$self->_test_six( $cache );
38	4					83	$self->_test_seven( $cache );
39	4					153	$self->_test_eight( $cache );
40	4					51	$self->_test_nine( $cache );
41	4					50	$self->_test_ten( $cache );
42	4					62	$self->_test_eleven( $cache );
43	4					128	$self->_test_twelve( $cache );
44	4					53	$self->_test_thirteen( $cache );
45	4					57	$self->_test_fourteen( $cache );
46	4					51	$self->_test_fifteen( $cache );
47	4					66	$self->_test_sixteen( $cache );
48	4					51	$self->_test_seventeen( $cache );
49							}
50							catch Error with
51							{
52	0			0		0	my $error = shift;
53
54	0					0	print STDERR "\nError:\n";
55	0					0	print STDERR $error->stringify( ) . "\n";
56	0					0	print STDERR $error->stacktrace( ) . "\n";
57	0					0	print STDERR "\n";
58							}
59	4					96	}
60
61
62							# Test the getting, setting, and removal of a scalar
63
64							sub _test_one
65							{
66	4			4		40	my ( $self, $cache ) = @_;
67
68	4	50				145	$cache or
69							croak( "cache required" );
70
71	4					51	my $key = 'Test Key';
72
73	4					40	my $value = 'Test Value';
74
75	4					153	$cache->set( $key, $value );
76
77	4					106	my $fetched_value = $cache->get( $key );
78
79	4	50				190	( $fetched_value eq $value ) ?
80							$self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
81
82	4					79	$cache->remove( $key );
83
84	4					62	my $fetched_removed_value = $cache->get( $key );
85
86	4	50				81	( not defined $fetched_removed_value ) ?
87							$self->ok( ) : $self->not_ok( 'not defined $fetched_removed_value' );
88							}
89
90
91							# Test the getting, setting, and removal of a list
92
93							sub _test_two
94							{
95	4			4		42	my ( $self, $cache ) = @_;
96
97	4	50				50	$cache or
98							croak( "cache required" );
99
100	4					41	my $key = 'Test Key';
101
102	4					45	my @value_list = ( 'One', 'Two', 'Three' );
103
104	4					62	$cache->set( $key, \@value_list );
105
106	4					87	my $fetched_value_list_ref = $cache->get( $key );
107
108	4	50	33			125	if ( ( $fetched_value_list_ref->[0] eq 'One' ) and
			33
109							( $fetched_value_list_ref->[1] eq 'Two' ) and
110							( $fetched_value_list_ref->[2] eq 'Three' ) )
111							{
112	4					63	$self->ok( );
113							}
114							else
115							{
116	0					0	$self->not_ok( 'fetched list does not match set list' );
117							}
118
119	4					59	$cache->remove( $key );
120
121	4					66	my $fetched_removed_value = $cache->get( $key );
122
123	4	50				108	( not defined $fetched_removed_value ) ?
124							$self->ok( ) : $self->not_ok( 'not defined $fetched_removed_value' );
125							}
126
127
128							# Test the getting, setting, and removal of a blessed object
129
130							sub _test_three
131							{
132	4			4		43	my ( $self, $cache ) = @_;
133
134	4	50				51	$cache or
135							croak( "cache required" );
136
137	4					40	my $key = 'Test Key';
138
139	4					39	my $value = 'Test Value';
140
141	4					56	$cache->set( $key, $value );
142
143	4					65	my $cache_key = 'Cache Key';
144
145	4					278	$cache->set( $cache_key, $cache );
146
147	4					94	my $fetched_cache = $cache->get( $cache_key );
148
149	4	50				73	( defined $fetched_cache ) ?
150							$self->ok( ) : $self->not_ok( 'defined $fetched_cache' );
151
152	4					55	my $fetched_value = $fetched_cache->get( $key );
153
154	4	50				75	( $fetched_value eq $value ) ?
155							$self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
156							}
157
158
159							# Test the expiration of an object
160
161							sub _test_four
162							{
163	4			4		41	my ( $self, $cache ) = @_;
164
165	4					40	my $expires_in = $EXPIRES_DELAY;
166
167	4					40	my $key = 'Test Key';
168
169	4					38	my $value = 'Test Value';
170
171	4					59	$cache->set( $key, $value, $expires_in );
172
173	4					82	my $fetched_value = $cache->get( $key );
174
175	4	50				69	( $fetched_value eq $value ) ?
176							$self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
177
178	4					12025796	sleep( $EXPIRES_DELAY + 1 );
179
180	4					144	my $fetched_expired_value = $cache->get( $key );
181
182	4	50				79	( not defined $fetched_expired_value ) ?
183							$self->ok( ) : $self->not_ok( 'not defined $fetched_expired_value' );
184							}
185
186
187
188							# Test that caches make deep copies of values
189
190							sub _test_five
191							{
192	4			4		42	my ( $self, $cache ) = @_;
193
194	4	50				767	$cache or
195							croak( "cache required" );
196
197	4					76	my $key = 'Test Key';
198
199	4					149	my @value_list = ( 'One', 'Two', 'Three' );
200
201	4					71	$cache->set( $key, \@value_list );
202
203	4					78	@value_list = ( );
204
205	4					61	my $fetched_value_list_ref = $cache->get( $key );
206
207	4	50	33			165	if ( ( $fetched_value_list_ref->[0] eq 'One' ) and
			33
208							( $fetched_value_list_ref->[1] eq 'Two' ) and
209							( $fetched_value_list_ref->[2] eq 'Three' ) )
210							{
211	4					61	$self->ok( );
212							}
213							else
214							{
215	0					0	$self->not_ok( 'fetched deep list does not match set deep list' );
216							}
217							}
218
219
220
221							# Test clearing a cache
222
223							sub _test_six
224							{
225	4			4		41	my ( $self, $cache ) = @_;
226
227	4	50				72	$cache or
228							croak( "cache required" );
229
230	4					40	my $key = 'Test Key';
231
232	4					51	my $value = 'Test Value';
233
234	4					53	$cache->set( $key, $value );
235
236	4					141	$cache->clear( );
237
238	4					65	my $fetched_cleared_value = $cache->get( $key );
239
240	4	50				120	( not defined $fetched_cleared_value ) ?
241							$self->ok( ) : $self->not_ok( 'not defined $fetched_cleared_value' );
242							}
243
244
245							# Test sizing of the cache
246
247							sub _test_seven
248							{
249	4			4		43	my ( $self, $cache ) = @_;
250
251	4					95	my $empty_size = $cache->size( );
252
253	4	50				64	( $empty_size == 0 ) ?
254							$self->ok( ) : $self->not_ok( '$empty_size == 0' );
255
256	4					39	my $first_key = 'First Test Key';
257
258	4					38	my $value = 'Test Value';
259
260	4					54	$cache->set( $first_key, $value );
261
262	4					91	my $first_size = $cache->size( );
263
264	4	50				69	( $first_size > $empty_size ) ?
265							$self->ok( ) : $self->not_ok( '$first_size > $empty_size' );
266
267	4					4810	my $second_key = 'Second Test Key';
268
269	4					72	$cache->set( $second_key, $value );
270
271	4					86	my $second_size = $cache->size( );
272
273	4	50				73	( $second_size > $first_size ) ?
274							$self->ok( ) : $self->not_ok( '$second_size > $first_size' );
275							}
276
277
278							# Test purging the cache
279
280							sub _test_eight
281							{
282	4			4		41	my ( $self, $cache ) = @_;
283
284	4					56	$cache->clear( );
285
286	4					98	my $empty_size = $cache->size( );
287
288	4	50				159	( $empty_size == 0 ) ?
289							$self->ok( ) : $self->not_ok( '$empty_size == 0' );
290
291	4					36	my $expires_in = $EXPIRES_DELAY;
292
293	4					41	my $key = 'Test Key';
294
295	4					40	my $value = 'Test Value';
296
297	4					57	$cache->set( $key, $value, $expires_in );
298
299	4					90	my $pre_purge_size = $cache->size( );
300
301	4	50				71	( $pre_purge_size > $empty_size ) ?
302							$self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' );
303
304	4					12022603	sleep( $EXPIRES_DELAY + 1 );
305
306	4					159	$cache->purge( );
307
308	4					63	my $post_purge_size = $cache->size( );
309
310	4	50				77	( $post_purge_size == $empty_size ) ?
311							$self->ok( ) : $self->not_ok( '$post_purge_size == $empty_size' );
312							}
313
314
315							# Test the getting, setting, and removal of a scalar across cache instances
316
317							sub _test_nine
318							{
319	4			4		41	my ( $self, $cache1 ) = @_;
320
321	4	50				49	$cache1 or
322							croak( "cache required" );
323
324	4	50				57	my $cache2 = $cache1->new( ) or
325							croak( "Couldn't construct new cache" );
326
327	4					42	my $key = 'Test Key';
328
329	4					38	my $value = 'Test Value';
330
331	4					56	$cache1->set( $key, $value );
332
333	4					85	my $fetched_value = $cache2->get( $key );
334
335	4	50				76	( $fetched_value eq $value ) ?
336							$self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
337							}
338
339
340							# Test Clear() and Size() as instance methods
341
342							sub _test_ten
343							{
344	4			4		45	my ( $self, $cache ) = @_;
345
346	4	50				79	$cache or
347							croak( "cache required" );
348
349	4					45	my $key = 'Test Key';
350
351	4					39	my $value = 'Test Value';
352
353	4					56	$cache->set( $key, $value );
354
355	4					84	my $full_size = $cache->Size( );
356
357	4	50				70	( $full_size > 0 ) ?
358							$self->ok( ) : $self->not_ok( '$full_size > 0' );
359
360	4					57	$cache->Clear( );
361
362	4					67	my $empty_size = $cache->Size( );
363
364	4	50				75	( $empty_size == 0 ) ?
365							$self->ok( ) : $self->not_ok( '$empty_size == 0' );
366							}
367
368
369							# Test Purge(), Clear(), and Size() as instance methods
370
371							sub _test_eleven
372							{
373	4			4		43	my ( $self, $cache ) = @_;
374
375	4					58	$cache->Clear( );
376
377	4					125	my $empty_size = $cache->Size( );
378
379	4	50				133	( $empty_size == 0 ) ?
380							$self->ok( ) : $self->not_ok( '$empty_size == 0' );
381
382	4					39	my $expires_in = $EXPIRES_DELAY;
383
384	4					44	my $key = 'Test Key';
385
386	4					38	my $value = 'Test Value';
387
388	4					60	$cache->set( $key, $value, $expires_in );
389
390	4					82	my $pre_purge_size = $cache->Size( );
391
392	4	50				73	( $pre_purge_size > $empty_size ) ?
393							$self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' );
394
395	4					12023435	sleep( $EXPIRES_DELAY + 1 );
396
397	4					106	$cache->Purge( );
398
399	4					66	my $purged_object = $cache->get_object( $key );
400
401	4	50				78	( not defined $purged_object ) ?
402							$self->ok( ) : $self->not_ok( 'not defined $purged_object' );
403							}
404
405
406							# Test Purge(), Clear(), and Size() as static methods
407
408							sub _test_twelve
409							{
410	4			4		42	my ( $self, $cache ) = @_;
411
412	4	50				130	my $class = ref $cache or
413							croak( "Couldn't get ref \$cache" );
414
415	4			4		95	no strict 'refs';
	4					44
	4					95
416
417	4					582	&{"${class}::Clear"}( );
	4					79
418
419	4					146	my $empty_size = &{"${class}::Size"}( );
	4					86
420
421	4	50				78	( $empty_size == 0 ) ?
422							$self->ok( ) : $self->not_ok( '$empty_size == 0' );
423
424	4					38	my $expires_in = $EXPIRES_DELAY;
425
426	4					42	my $key = 'Test Key';
427
428	4					39	my $value = 'Test Value';
429
430	4					57	$cache->set( $key, $value, $expires_in );
431
432	4					64	my $pre_purge_size = &{"${class}::Size"}( );
	4					76
433
434	4	50				91	( $pre_purge_size > $empty_size ) ?
435							$self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' );
436
437	4					12020376	sleep( $EXPIRES_DELAY + 1 );
438
439	4					62	&{"${class}::Purge"}( );
	4					114
440
441	4					68	my $purged_object = $cache->get_object( $key );
442
443	4	50				97	( not defined $purged_object ) ?
444							$self->ok( ) : $self->not_ok( 'not defined $purged_object' );
445
446	4			4		69	use strict;
	4					37
	4					65
447							}
448
449
450
451							# Test the expiration of an object with extended syntax
452
453							sub _test_thirteen
454							{
455	4			4		45	my ( $self, $cache ) = @_;
456
457	4					45	my $expires_in = $EXPIRES_DELAY;
458
459	4					38	my $key = 'Test Key';
460
461	4					39	my $value = 'Test Value';
462
463	4					58	$cache->set( $key, $value, $expires_in );
464
465	4					86	my $fetched_value = $cache->get( $key );
466
467	4	50				75	( $fetched_value eq $value ) ?
468							$self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
469
470	4					12020541	sleep( $EXPIRES_DELAY + 1 );
471
472	4					116	my $fetched_expired_value = $cache->get( $key );
473
474	4	50				87	( not defined $fetched_expired_value ) ?
475							$self->ok( ) : $self->not_ok( 'not defined $fetched_expired_value' );
476							}
477
478
479							# test the get_keys method
480
481							sub _test_fourteen
482							{
483	4			4		43	my ( $self, $cache ) = @_;
484
485	4					2512	$cache->Clear( );
486
487	4					69	my $empty_size = $cache->Size( );
488
489	4	50				78	( $empty_size == 0 ) ?
490							$self->ok( ) : $self->not_ok( '$empty_size == 0' );
491
492	4					74	my @keys = sort ( 'John', 'Paul', 'Ringo', 'George' );
493
494	4					42	my $value = 'Test Value';
495
496	4					42	foreach my $key ( @keys )
497							{
498	16					266	$cache->set( $key, $value );
499							}
500
501	4					87	my @cached_keys = sort $cache->get_keys( );
502
503	4					58	my $arrays_equal = Arrays_Are_Equal( \@keys, \@cached_keys );
504
505	4	50				71	( $arrays_equal == 1 ) ?
506							$self->ok( ) : $self->not_ok( '$arrays_equal == 1' );
507							}
508
509
510							# test the auto_purge on set functionality
511
512							sub _test_fifteen
513							{
514	4			4		41	my ( $self, $cache ) = @_;
515
516	4					58	$cache->Clear( );
517
518	4					52	my $expires_in = $EXPIRES_DELAY;
519
520	4					101	$cache->set_auto_purge_interval( $expires_in );
521
522	4					56	$cache->set_auto_purge_on_set( 1 );
523
524	4					40	my $key = 'Test Key';
525
526	4					40	my $value = 'Test Value';
527
528	4					59	$cache->set( $key, $value, $expires_in );
529
530	4					88	my $fetched_value = $cache->get( $key );
531
532	4	50				1840	( $fetched_value eq $value ) ?
533							$self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
534
535	4					12034749	sleep( $EXPIRES_DELAY + 1 );
536
537	4					113	$cache->set( "Trigger auto_purge", "Empty" );
538
539	4					93	my $fetched_expired_object = $cache->get_object( $key );
540
541	4	50				88	( not defined $fetched_expired_object ) ?
542							$self->ok( ) : $self->not_ok( 'not defined $fetched_expired_object' );
543
544	4					58	$cache->Clear( );
545							}
546
547
548
549							# test the auto_purge_interval functionality
550
551							sub _test_sixteen
552							{
553	4			4		43	my ( $self, $cache ) = @_;
554
555	4					40	my $expires_in = $EXPIRES_DELAY;
556
557							eval
558	4					40	{
559	4					66	$cache = $cache->new( { 'auto_purge_interval' => $expires_in } );
560							};
561
562	4	50				77	( not defined @$ ) ?
563							$self->ok( ) : $self->not_ok( "couldn't create autopurge cache" );
564							}
565
566
567							# test the get_namespaces method
568
569							sub _test_seventeen
570							{
571	4			4		48	my ( $self, $cache ) = @_;
572
573	4					55	$cache->set( 'foo', 'bar' );
574
575	4	50				122	if ( Arrays_Are_Equal( [ sort( $cache->get_namespaces( ) ) ],
576							[ sort( 'Default', '__AUTO_PURGE__' ) ] ) )
577							{
578	4					61	$self->ok( );
579							}
580							else
581							{
582	0					0	$self->not_ok( "get_namespaces returned the wrong namespaces" );
583							}
584
585	4					74	$cache->Clear( );
586							}
587
588
589							# test the auto_purge on get functionality
590
591							sub _test_eighteen
592							{
593	0			0		0	my ( $self, $cache ) = @_;
594
595	0					0	$cache->Clear( );
596
597	0					0	my $expires_in = $EXPIRES_DELAY;
598
599	0					0	$cache->set_auto_purge_interval( $expires_in );
600
601	0					0	$cache->set_auto_purge_on_get( 1 );
602
603	0					0	my $key = 'Test Key';
604
605	0					0	my $key_two = 'Test Key Two';
606
607	0					0	my $value = 'Test Value';
608
609	0					0	$cache->set( $key, $value, $expires_in );
610
611	0					0	$cache->set( $key_two, $value, $expires_in );
612
613	0					0	my $fetched_value = $cache->get( $key );
614
615	0	0				0	( $fetched_value eq $value ) ?
616							$self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
617
618	0					0	my $fetched_value_two = $cache->get( $key_two );
619
620	0	0				0	( $fetched_value_two eq $value ) ?
621							$self->ok( ) : $self->not_ok( '$fetched_value eq $value' );
622
623	0					0	sleep( $EXPIRES_DELAY + 1 );
624
625	0					0	$cache->get( 'Text Key' ); # trigger purge for key_two
626
627	0					0	my $fetched_expired_object = $cache->get_object( $key_two );
628
629	0	0				0	( not defined $fetched_expired_object ) ?
630							$self->ok( ) : $self->not_ok( 'not defined $fetched_expired_object' );
631
632	0					0	$cache->Clear( );
633							}
634
635
636
637							sub Arrays_Are_Equal
638							{
639	8			8	0	81	my ( $first_array_ref, $second_array_ref ) = @_;
640
641	8					106	local $^W = 0; # silence spurious -w undef complaints
642
643	8	50				96	return 0 unless @$first_array_ref == @$second_array_ref;
644
645							for (my $i = 0; $i < @$first_array_ref; $i++)
646							{
647	24	50				633	return 0 if $first_array_ref->[$i] ne $second_array_ref->[$i];
648	8					1836	}
649
650	8					102	return 1;
651							}
652
653
654							1;
655
656
657							__END__
658
659							=pod
660
661							=head1 NAME
662
663							Cache::CacheTester -- a class for regression testing caches
664
665							=head1 DESCRIPTION
666
667							The CacheTester is used to verify that a cache implementation honors
668							its contract.
669
670							=head1 SYNOPSIS
671
672							use Cache::MemoryCache;
673							use Cache::CacheTester;
674
675							my $cache = new Cache::MemoryCache( );
676
677							my $cache_tester = new Cache::CacheTester( 1 );
678
679							$cache_tester->test( $cache );
680
681							=head1 METHODS
682
683							=over
684
685							=item B<new( $initial_count )>
686
687							Construct a new CacheTester object, with the counter starting at
688							I<$initial_count>.
689
690							=item B<test( )>
691
692							Run the tests.
693
694							=back
695
696							=head1 SEE ALSO
697
698							Cache::Cache, Cache::BaseCacheTester
699
700							=head1 AUTHOR
701
702							Original author: DeWitt Clinton <dewitt@unto.net>
703
704							Last author: $Author: dclinton $
705
706							Copyright (C) 2001-2003 DeWitt Clinton
707
708							=cut
709
710