7f088637fa3860421d13e4a46d7a50f48faa050c
2 use lib
(split(/:/, $ENV{GITPERLLIB
}));
8 use Fcntl
qw(:DEFAULT);
16 use lib
$ENV{GITWEBLIBDIR
} || "$ENV{GIT_BUILD_DIR}/gitweb/lib";
19 # Test creating a cache
21 BEGIN { use_ok
('GitwebCache::FileCacheWithLocking'); }
22 diag
("Using lib '$INC[0]'");
23 diag
("Testing '$INC{'GitwebCache/FileCacheWithLocking.pm'}'");
25 my $cache = new_ok
('GitwebCache::FileCacheWithLocking', [ {
26 'max_lifetime' => 0, # turn it off
27 'background_cache' => 0,
29 isa_ok
($cache, 'GitwebCache::SimpleFileCache');
31 # compute can fork, don't generate zombies
32 #local $SIG{CHLD} = 'IGNORE';
34 # Test that default values are defined
36 ok
(defined $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_ROOT
,
37 '$DEFAULT_CACHE_ROOT defined');
38 ok
(defined $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_DEPTH
,
39 '$DEFAULT_CACHE_DEPTH defined');
41 # Test accessors and default values for cache
44 skip
'default values not defined', 3
45 unless ($GitwebCache::SimpleFileCache
::DEFAULT_CACHE_ROOT
&&
46 $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_DEPTH
);
48 is
($cache->get_namespace(), '', "default namespace is ''");
49 cmp_ok
($cache->get_root(), 'eq', $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_ROOT
,
50 "default cache root is '$GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT'");
51 cmp_ok
($cache->get_depth(), '==', $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_DEPTH
,
52 "default cache depth is $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH");
55 # ----------------------------------------------------------------------
58 # Test the getting, setting, and removal of a cached value
59 # (Cache::Cache interface)
62 my $value = 'Test Value';
64 subtest
'Cache::Cache interface' => sub {
65 foreach my $method (qw(get set remove)) {
66 can_ok
($cache, $method);
69 $cache->set($key, $value);
70 cmp_ok
($cache->get_size($key), '>', 0, 'get_size after set, is greater than 0');
71 is
($cache->get($key), $value, 'get after set, returns cached value');
73 ok
(!defined($cache->get($key)), 'get after remove, is undefined');
75 eval { $cache->remove('Not-Existent Key'); };
76 ok
(!$@
, 'remove on non-existent key doesn\'t die');
82 # Test the getting and setting of a cached value
90 subtest
'CHI interface' => sub {
91 can_ok
($cache, qw(compute));
93 is
($cache->compute($key, \
&get_value
), $value, "compute 1st time (set) returns '$value'");
94 is
($cache->compute($key, \
&get_value
), $value, "compute 2nd time (get) returns '$value'");
95 is
($cache->compute($key, \
&get_value
), $value, "compute 3rd time (get) returns '$value'");
96 cmp_ok
($call_count, '==', 1, 'get_value() is called once from compute');
101 # Test the getting and setting of a cached value
102 # (compute_fh interface)
110 subtest
'compute_fh interface' => sub {
111 can_ok
($cache, qw(compute_fh));
113 $cache->remove($key);
114 is
(cache_compute_fh
($cache, $key, \
&write_value
), $value,
115 "compute_fh 1st time (set) returns '$value'");
116 is
(cache_compute_fh
($cache, $key, \
&write_value
), $value,
117 "compute_fh 2nd time (get) returns '$value'");
118 is
(cache_compute_fh
($cache, $key, \
&write_value
), $value,
119 "compute_fh 3rd time (get) returns '$value'");
120 cmp_ok
($call_count, '==', 1, 'write_value() is called once from compute_fh');
125 # Test cache expiration
127 subtest
'cache expiration' => sub {
128 $cache->set_expires_in(60*60*24); # set expire time to 1 day
129 cmp_ok
($cache->get_expires_in(), '>', 0, '"expires in" is greater than 0');
130 is
($cache->get($key), $value, 'get returns cached value (not expired in 1d)');
132 $cache->set_expires_in(-1); # set expire time to never expire
133 is
($cache->get_expires_in(), -1, '"expires in" is set to never (-1)');
134 is
($cache->get($key), $value, 'get returns cached value (not expired)');
136 $cache->set_expires_in(0);
137 is
($cache->get_expires_in(), 0, '"expires in" is set to now (0)');
138 $cache->set($key, $value);
139 ok
(!defined($cache->get($key)), 'cache is expired');
144 # Test assertions for adaptive cache expiration
147 sub load
{ return $load; }
148 my $expires_min = 10;
149 my $expires_max = 30;
150 $cache->set_expires_in(-1);
151 $cache->set_expires_min($expires_min);
152 $cache->set_expires_max($expires_max);
153 $cache->set_check_load(\
&load
);
154 subtest
'adaptive cache expiration' => sub {
155 cmp_ok
($cache->get_expires_min(), '==', $expires_min,
156 '"expires min" set correctly');
157 cmp_ok
($cache->get_expires_max(), '==', $expires_max,
158 '"expires max" set correctly');
161 cmp_ok
($cache->get_expires_in(), '>=', $expires_min,
162 '"expires in" bound from down for load=0');
163 cmp_ok
($cache->get_expires_in(), '<=', $expires_max,
164 '"expires in" bound from up for load=0');
167 cmp_ok
($cache->get_expires_in(), '>=', $expires_min,
168 '"expires in" bound from down for heavy load');
169 cmp_ok
($cache->get_expires_in(), '<=', $expires_max,
170 '"expires in" bound from up for heavy load');
175 $cache->set_expires_in(-1);
177 # ----------------------------------------------------------------------
179 sub parallel_run
(&); # forward declaration of prototype
181 # Test 'stampeding herd' / 'cache miss stampede' problem
184 my $slow_time = 1; # how many seconds to sleep in mockup of slow generation
190 sub get_value_slow_fh
{
200 die "get_value_die\n";
203 my $lock_file = "$0.$$.lock";
204 sub get_value_die_once
{
205 if (sysopen my $fh, $lock_file, (O_WRONLY
| O_CREAT
| O_EXCL
)) {
207 die "get_value_die_once\n";
218 note
("Following tests contain artifical delay of $slow_time seconds");
219 subtest
'parallel access' => sub {
220 $cache->remove($key);
221 @output = parallel_run
{
223 my $data = cache_get_set
($cache, $key, \
&get_value_slow
);
224 print "$data$sep$call_count";
228 my ($child_out, $child_count) = split(quotemeta $sep, $_);
229 #is($child_out, $value, "get/set (parallel) returns '$value'");
230 $total_count += $child_count;
232 cmp_ok
($total_count, '==', 2, 'parallel get/set: get_value_slow() called twice');
234 $cache->remove($key);
235 @output = parallel_run
{
237 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
238 print "$data$sep$call_count";
242 my ($child_out, $child_count) = split(quotemeta $sep, $_);
243 #is($child_out, $value, "compute (parallel) returns '$value'");
244 $total_count += $child_count;
246 cmp_ok
($total_count, '==', 1, 'parallel compute: get_value_slow() called once');
248 $cache->remove($key);
249 @output = parallel_run
{
251 my $data = cache_compute_fh
($cache, $key, \
&get_value_slow_fh
);
252 print "$data$sep$call_count";
256 my ($child_out, $child_count) = split(quotemeta $sep, $_);
257 #is($child_out, $value, "compute_fh (parallel) returns '$value'");
258 $total_count += $child_count;
260 cmp_ok
($total_count, '==', 1, 'parallel compute_fh: get_value_slow_fh() called once');
263 local $SIG{ALRM
} = sub { die "alarm\n"; };
266 @output = parallel_run
{
268 my $data = eval { cache_compute
($cache, 'No Key', \
&get_value_die
); };
270 print "$data" if defined $data;
272 print "$eval_error" if defined $eval_error;
276 [ ( "${sep}get_value_die\n" ) x
2 ],
277 'parallel compute: get_value_die() died in both'
282 ok
(!$@
, 'parallel compute: no alarm call (neither process hung)');
285 $cache->remove($key);
287 @output = parallel_run
{
288 my $data = eval { cache_compute
($cache, $key, \
&get_value_die_once
); };
290 print "$data" if defined $data;
292 print "$eval_error" if defined $eval_error;
296 [sort ("$value$sep", "${sep}get_value_die_once\n")],
297 'parallel compute: return correct value even if other process died'
304 # Test that cache returns stale data in existing but expired cache situation
305 # (probably should be run only if GIT_TEST_LONG)
307 my $stale_value = 'Stale Value';
309 subtest
'serving stale data when (re)generating' => sub {
310 # without background generation
311 $cache->set_background_cache(0);
313 $cache->set($key, $stale_value);
315 $cache->set_expires_in(0); # expire now
316 $cache->set_max_lifetime(-1); # forever (always serve stale data)
318 @output = parallel_run
{
319 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
322 # returning stale data works
325 [sort ($value, $stale_value)],
326 'no background: stale data returned by one process'
329 $cache->set_expires_in(-1); # never expire for next ->get
330 is
($cache->get($key), $value,
331 'no background: value got set correctly, even if stale data returned');
334 # with background generation
335 $cache->set_background_cache(1);
337 $cache->set($key, $stale_value);
338 $cache->set_expires_in(0); # set value is now expired
339 @output = parallel_run
{
340 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
343 # returning stale data works
346 [ ($stale_value) x
2 ],
347 'background: stale data returned by both process when expired'
350 $cache->set_expires_in(-1); # never expire for next ->get
351 note
('waiting for background process to have time to set data');
352 sleep $slow_time; # wait for background process to have chance to set data
353 is
($cache->get($key), $value,
354 'background: value got set correctly by background process');
357 # $cache->set($key, $stale_value);
358 # unlink($lock_file);
359 # @output = parallel_run {
360 # my $data = eval { cache_compute($cache, $key, \&get_value_die_once); };
361 # my $eval_error = $@;
362 # print "$data" if defined $data;
364 # print "$eval_error" if defined $eval_error;
367 # local $TODO = 'not implemented';
371 # [sort ("$value${sep}", "${sep}get_value_die_once\n")],
372 # 'return non-stale value, even if process regenerating it died'
375 # $cache->set_expires_in(-1); # never expire for next ->get
376 # is($cache->get($key), $value,
377 # 'value got regenerated, even if process regenerating it died');
379 # unlink($lock_file);
381 $cache->set($key, $stale_value);
382 $cache->set_expires_in(0); # expire now
383 $cache->set_max_lifetime(0); # don't serve stale data
385 @output = parallel_run
{
386 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
389 # no returning stale data
390 ok
(!scalar(grep { $_ eq $stale_value } @output),
391 'no stale data if configured');
396 $cache->set_expires_in(-1);
401 #######################################################################
402 #######################################################################
403 #######################################################################
405 # use ->get($key) and ->set($key, $data) interface
407 my ($cache, $key, $code) = @_;
409 my $data = $cache->get($key);
410 if (!defined $data) {
412 $cache->set($key, $data);
418 # use ->compute($key, $code) interface
420 my ($cache, $key, $code) = @_;
422 my $data = $cache->compute($key, $code);
425 # use ->compute_fh($key, $code_fh) interface
426 sub cache_compute_fh
{
427 my ($cache, $key, $code_fh) = @_;
429 my ($fh, $filename) = $cache->compute_fh($key, $code_fh);
435 # from http://aaroncrane.co.uk/talks/pipes_and_processes/
437 my ($child_process_code) = @_;
440 die "Failed to fork: $!\n" if !defined $pid;
442 return $pid if $pid != 0;
444 # Now we're in the new child process
445 $child_process_code->();
449 sub parallel_run
(&) {
450 my $child_code = shift;
454 my (%pid_for_child, %fd_for_child);
455 my $sel = IO
::Select
->new();
456 foreach my $child_idx (1..$nchildren) {
457 my $pipe = IO
::Pipe
->new()
458 or die "Failed to create pipe: $!\n";
460 my $pid = fork_child
{
462 or die "$$: Child \$pipe->writer(): $!\n";
463 dup2
(fileno($pipe), fileno(STDOUT
))
464 or die "$$: Child $child_idx failed to reopen stdout to pipe: $!\n";
466 or die "$$: Child $child_idx failed to close pipe: $!\n";
468 # From Test-Simple-0.96/t/subtest/fork.t
470 # Force all T::B output into the pipe (redirected to STDOUT),
471 # for the parent builder as well as the current subtest builder.
473 no warnings
'redefine';
474 *Test
::Builder
::output
= sub { *STDOUT
};
475 *Test
::Builder
::failure_output
= sub { *STDOUT
};
476 *Test
::Builder
::todo_output
= sub { *STDOUT
};
485 $pid_for_child{$pid} = $child_idx;
487 or die "Failed to \$pipe->reader(): $!\n";
488 $fd_for_child{$pipe} = $child_idx;
491 $children{$child_idx} = {
498 while (my @ready = $sel->can_read()) {
499 foreach my $fh (@ready) {
501 my $nread = sysread($fh, $buf, 1024);
503 exists $fd_for_child{$fh}
504 or die "Cannot find child for fd: $fh\n";
507 $children{$fd_for_child{$fh}}{'output'} .= $buf;
514 while (%pid_for_child) {
515 my $pid = waitpid -1, 0;
516 warn "Child $pid_for_child{$pid} ($pid) failed with status: $?\n"
518 delete $pid_for_child{$pid};
521 return map { $children{$_}{'output'} } keys %children;