480cfbc74aa089b4eb66e3b42c911563370164d0
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);
336 $cache->set_generating_info_is_safe(1);
338 $cache->set($key, $stale_value);
339 $cache->set_expires_in(0); # set value is now expired
340 @output = parallel_run
{
341 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
344 # returning stale data works
347 [ ($stale_value) x
2 ],
348 'background: stale data returned by both process when expired'
351 $cache->set_expires_in(-1); # never expire for next ->get
352 note
('waiting for background process to have time to set data');
353 sleep $slow_time; # wait for background process to have chance to set data
354 is
($cache->get($key), $value,
355 'background: value got set correctly by background process');
358 # $cache->set($key, $stale_value);
359 # unlink($lock_file);
360 # @output = parallel_run {
361 # my $data = eval { cache_compute($cache, $key, \&get_value_die_once); };
362 # my $eval_error = $@;
363 # print "$data" if defined $data;
365 # print "$eval_error" if defined $eval_error;
368 # local $TODO = 'not implemented';
372 # [sort ("$value${sep}", "${sep}get_value_die_once\n")],
373 # 'return non-stale value, even if process regenerating it died'
376 # $cache->set_expires_in(-1); # never expire for next ->get
377 # is($cache->get($key), $value,
378 # 'value got regenerated, even if process regenerating it died');
380 # unlink($lock_file);
382 $cache->set($key, $stale_value);
383 $cache->set_expires_in(0); # expire now
384 $cache->set_max_lifetime(0); # don't serve stale data
386 @output = parallel_run
{
387 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
390 # no returning stale data
391 ok
(!scalar(grep { $_ eq $stale_value } @output),
392 'no stale data if configured');
397 $cache->set_expires_in(-1);
400 # Test 'generating_info' feature
402 $cache->remove($key);
403 my $progress_info = "Generating...";
404 sub test_generating_info
{
406 print "$progress_info";
408 $cache->set_generating_info(\
&test_generating_info
);
410 subtest
'generating progress info' => sub {
413 # without background generation
414 $cache->set_background_cache(0);
415 $cache->remove($key);
417 @output = parallel_run
{
418 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
421 @progress = map { s/^(.*)\Q${sep}\E//o && $1 } @output;
424 [sort ('', $progress_info)],
425 'no background: one process waiting for data prints progress info'
430 'no background: both processes return correct value'
434 # without background generation, with stale value
435 $cache->set($key, $stale_value);
436 $cache->set_expires_in(0); # set value is now expired
437 $cache->set_max_lifetime(-1); # stale data never expire
438 @output = parallel_run
{
439 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
444 ## no progress for generating process without background generation;
445 # [sort ("$progress_info$sep$value", "$sep$stale_value")],
446 [sort ("$sep$value", "$sep$stale_value")],
447 'no background, stale data: generating gets data, other gets stale data'
448 ) or diag
('@output is ', join ", ", sort @output);
449 $cache->set_expires_in(-1);
452 # with background generation
453 $cache->set_background_cache(1);
454 $cache->remove($key);
456 @output = parallel_run
{
457 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
460 @progress = map { s/^(.*)\Q${sep}\E//o && $1 } @output;
463 [ ($progress_info) x
2],
464 'background: both process print progress info'
469 'background: both processes return correct value'
475 $cache->set_expires_in(-1);
481 #######################################################################
482 #######################################################################
483 #######################################################################
485 # use ->get($key) and ->set($key, $data) interface
487 my ($cache, $key, $code) = @_;
489 my $data = $cache->get($key);
490 if (!defined $data) {
492 $cache->set($key, $data);
498 # use ->compute($key, $code) interface
500 my ($cache, $key, $code) = @_;
502 my $data = $cache->compute($key, $code);
505 # use ->compute_fh($key, $code_fh) interface
506 sub cache_compute_fh
{
507 my ($cache, $key, $code_fh) = @_;
509 my ($fh, $filename) = $cache->compute_fh($key, $code_fh);
515 # from http://aaroncrane.co.uk/talks/pipes_and_processes/
517 my ($child_process_code) = @_;
520 die "Failed to fork: $!\n" if !defined $pid;
522 return $pid if $pid != 0;
524 # Now we're in the new child process
525 $child_process_code->();
529 sub parallel_run
(&) {
530 my $child_code = shift;
534 my (%pid_for_child, %fd_for_child);
535 my $sel = IO
::Select
->new();
536 foreach my $child_idx (1..$nchildren) {
537 my $pipe = IO
::Pipe
->new()
538 or die "Failed to create pipe: $!\n";
540 my $pid = fork_child
{
542 or die "$$: Child \$pipe->writer(): $!\n";
543 dup2
(fileno($pipe), fileno(STDOUT
))
544 or die "$$: Child $child_idx failed to reopen stdout to pipe: $!\n";
546 or die "$$: Child $child_idx failed to close pipe: $!\n";
548 # From Test-Simple-0.96/t/subtest/fork.t
550 # Force all T::B output into the pipe (redirected to STDOUT),
551 # for the parent builder as well as the current subtest builder.
553 no warnings
'redefine';
554 *Test
::Builder
::output
= sub { *STDOUT
};
555 *Test
::Builder
::failure_output
= sub { *STDOUT
};
556 *Test
::Builder
::todo_output
= sub { *STDOUT
};
565 $pid_for_child{$pid} = $child_idx;
567 or die "Failed to \$pipe->reader(): $!\n";
568 $fd_for_child{$pipe} = $child_idx;
571 $children{$child_idx} = {
578 while (my @ready = $sel->can_read()) {
579 foreach my $fh (@ready) {
581 my $nread = sysread($fh, $buf, 1024);
583 exists $fd_for_child{$fh}
584 or die "Cannot find child for fd: $fh\n";
587 $children{$fd_for_child{$fh}}{'output'} .= $buf;
594 while (%pid_for_child) {
595 my $pid = waitpid -1, 0;
596 warn "Child $pid_for_child{$pid} ($pid) failed with status: $?\n"
598 delete $pid_for_child{$pid};
601 return map { $children{$_}{'output'} } keys %children;