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