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
28 isa_ok
($cache, 'GitwebCache::SimpleFileCache');
30 # Test that default values are defined
32 ok
(defined $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_ROOT
,
33 '$DEFAULT_CACHE_ROOT defined');
34 ok
(defined $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_DEPTH
,
35 '$DEFAULT_CACHE_DEPTH defined');
37 # Test accessors and default values for cache
40 skip
'default values not defined', 3
41 unless ($GitwebCache::SimpleFileCache
::DEFAULT_CACHE_ROOT
&&
42 $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_DEPTH
);
44 is
($cache->get_namespace(), '', "default namespace is ''");
45 cmp_ok
($cache->get_root(), 'eq', $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_ROOT
,
46 "default cache root is '$GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT'");
47 cmp_ok
($cache->get_depth(), '==', $GitwebCache::SimpleFileCache
::DEFAULT_CACHE_DEPTH
,
48 "default cache depth is $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH");
51 # ----------------------------------------------------------------------
54 # Test the getting, setting, and removal of a cached value
55 # (Cache::Cache interface)
58 my $value = 'Test Value';
60 subtest
'Cache::Cache interface' => sub {
61 foreach my $method (qw(get set remove)) {
62 can_ok
($cache, $method);
65 $cache->set($key, $value);
66 cmp_ok
($cache->get_size($key), '>', 0, 'get_size after set, is greater than 0');
67 is
($cache->get($key), $value, 'get after set, returns cached value');
69 ok
(!defined($cache->get($key)), 'get after remove, is undefined');
71 eval { $cache->remove('Not-Existent Key'); };
72 ok
(!$@
, 'remove on non-existent key doesn\'t die');
78 # Test the getting and setting of a cached value
86 subtest
'CHI interface' => sub {
87 can_ok
($cache, qw(compute));
89 is
($cache->compute($key, \
&get_value
), $value, "compute 1st time (set) returns '$value'");
90 is
($cache->compute($key, \
&get_value
), $value, "compute 2nd time (get) returns '$value'");
91 is
($cache->compute($key, \
&get_value
), $value, "compute 3rd time (get) returns '$value'");
92 cmp_ok
($call_count, '==', 1, 'get_value() is called once from compute');
97 # Test the getting and setting of a cached value
98 # (compute_fh interface)
106 subtest
'compute_fh interface' => sub {
107 can_ok
($cache, qw(compute_fh));
109 $cache->remove($key);
110 is
(cache_compute_fh
($cache, $key, \
&write_value
), $value,
111 "compute_fh 1st time (set) returns '$value'");
112 is
(cache_compute_fh
($cache, $key, \
&write_value
), $value,
113 "compute_fh 2nd time (get) returns '$value'");
114 is
(cache_compute_fh
($cache, $key, \
&write_value
), $value,
115 "compute_fh 3rd time (get) returns '$value'");
116 cmp_ok
($call_count, '==', 1, 'write_value() is called once from compute_fh');
121 # Test cache expiration
123 subtest
'cache expiration' => sub {
124 $cache->set_expires_in(60*60*24); # set expire time to 1 day
125 cmp_ok
($cache->get_expires_in(), '>', 0, '"expires in" is greater than 0');
126 is
($cache->get($key), $value, 'get returns cached value (not expired in 1d)');
128 $cache->set_expires_in(-1); # set expire time to never expire
129 is
($cache->get_expires_in(), -1, '"expires in" is set to never (-1)');
130 is
($cache->get($key), $value, 'get returns cached value (not expired)');
132 $cache->set_expires_in(0);
133 is
($cache->get_expires_in(), 0, '"expires in" is set to now (0)');
134 $cache->set($key, $value);
135 ok
(!defined($cache->get($key)), 'cache is expired');
140 # Test assertions for adaptive cache expiration
143 sub load
{ return $load; }
144 my $expires_min = 10;
145 my $expires_max = 30;
146 $cache->set_expires_in(-1);
147 $cache->set_expires_min($expires_min);
148 $cache->set_expires_max($expires_max);
149 $cache->set_check_load(\
&load
);
150 subtest
'adaptive cache expiration' => sub {
151 cmp_ok
($cache->get_expires_min(), '==', $expires_min,
152 '"expires min" set correctly');
153 cmp_ok
($cache->get_expires_max(), '==', $expires_max,
154 '"expires max" set correctly');
157 cmp_ok
($cache->get_expires_in(), '>=', $expires_min,
158 '"expires in" bound from down for load=0');
159 cmp_ok
($cache->get_expires_in(), '<=', $expires_max,
160 '"expires in" bound from up for load=0');
163 cmp_ok
($cache->get_expires_in(), '>=', $expires_min,
164 '"expires in" bound from down for heavy load');
165 cmp_ok
($cache->get_expires_in(), '<=', $expires_max,
166 '"expires in" bound from up for heavy load');
171 $cache->set_expires_in(-1);
173 # ----------------------------------------------------------------------
175 sub parallel_run
(&); # forward declaration of prototype
177 # Test 'stampeding herd' / 'cache miss stampede' problem
180 my $slow_time = 1; # how many seconds to sleep in mockup of slow generation
186 sub get_value_slow_fh
{
196 die "get_value_die\n";
199 my $lock_file = "$0.$$.lock";
200 sub get_value_die_once
{
201 if (sysopen my $fh, $lock_file, (O_WRONLY
| O_CREAT
| O_EXCL
)) {
203 die "get_value_die_once\n";
214 note
("Following tests contain artifical delay of $slow_time seconds");
215 subtest
'parallel access' => sub {
216 $cache->remove($key);
217 @output = parallel_run
{
219 my $data = cache_get_set
($cache, $key, \
&get_value_slow
);
220 print "$data$sep$call_count";
224 my ($child_out, $child_count) = split(quotemeta $sep, $_);
225 #is($child_out, $value, "get/set (parallel) returns '$value'");
226 $total_count += $child_count;
228 cmp_ok
($total_count, '==', 2, 'parallel get/set: get_value_slow() called twice');
230 $cache->remove($key);
231 @output = parallel_run
{
233 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
234 print "$data$sep$call_count";
238 my ($child_out, $child_count) = split(quotemeta $sep, $_);
239 #is($child_out, $value, "compute (parallel) returns '$value'");
240 $total_count += $child_count;
242 cmp_ok
($total_count, '==', 1, 'parallel compute: get_value_slow() called once');
244 $cache->remove($key);
245 @output = parallel_run
{
247 my $data = cache_compute_fh
($cache, $key, \
&get_value_slow_fh
);
248 print "$data$sep$call_count";
252 my ($child_out, $child_count) = split(quotemeta $sep, $_);
253 #is($child_out, $value, "compute_fh (parallel) returns '$value'");
254 $total_count += $child_count;
256 cmp_ok
($total_count, '==', 1, 'parallel compute_fh: get_value_slow_fh() called once');
259 local $SIG{ALRM
} = sub { die "alarm\n"; };
262 @output = parallel_run
{
264 my $data = eval { cache_compute
($cache, 'No Key', \
&get_value_die
); };
266 print "$data" if defined $data;
268 print "$eval_error" if defined $eval_error;
272 [ ( "${sep}get_value_die\n" ) x
2 ],
273 'parallel compute: get_value_die() died in both'
278 ok
(!$@
, 'parallel compute: no alarm call (neither process hung)');
281 $cache->remove($key);
283 @output = parallel_run
{
284 my $data = eval { cache_compute
($cache, $key, \
&get_value_die_once
); };
286 print "$data" if defined $data;
288 print "$eval_error" if defined $eval_error;
292 [sort ("$value$sep", "${sep}get_value_die_once\n")],
293 'parallel compute: return correct value even if other process died'
300 # Test that cache returns stale data in existing but expired cache situation
301 # (probably should be run only if GIT_TEST_LONG)
303 my $stale_value = 'Stale Value';
305 subtest
'serving stale data when (re)generating' => sub {
306 $cache->set($key, $stale_value);
308 $cache->set_expires_in(0); # expire now
309 $cache->set_max_lifetime(-1); # forever (always serve stale data)
311 @output = parallel_run
{
312 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
315 ok
(scalar(grep { $_ eq $stale_value } @output),
316 'stale data in at least one process when expired');
318 $cache->set_expires_in(-1); # never expire for next ->get
319 is
($cache->get($key), $value,
320 'value got set correctly, even if stale data returned');
323 # $cache->set($key, $stale_value);
324 # unlink($lock_file);
325 # @output = parallel_run {
326 # my $data = eval { cache_compute($cache, $key, \&get_value_die_once); };
327 # my $eval_error = $@;
328 # print "$data" if defined $data;
330 # print "$eval_error" if defined $eval_error;
333 # local $TODO = 'not implemented';
337 # [sort ("$value${sep}", "${sep}get_value_die_once\n")],
338 # 'return non-stale value, even if process regenerating it died'
341 # $cache->set_expires_in(-1); # never expire for next ->get
342 # is($cache->get($key), $value,
343 # 'value got regenerated, even if process regenerating it died');
345 # unlink($lock_file);
347 $cache->set($key, $stale_value);
348 $cache->set_expires_in(0); # expire now
349 $cache->set_max_lifetime(0); # don't serve stale data
351 @output = parallel_run
{
352 my $data = cache_compute
($cache, $key, \
&get_value_slow
);
355 # no returning stale data
356 ok
(!scalar(grep { $_ eq $stale_value } @output),
357 'no stale data if configured');
362 $cache->set_expires_in(-1);
367 #######################################################################
368 #######################################################################
369 #######################################################################
371 # use ->get($key) and ->set($key, $data) interface
373 my ($cache, $key, $code) = @_;
375 my $data = $cache->get($key);
376 if (!defined $data) {
378 $cache->set($key, $data);
384 # use ->compute($key, $code) interface
386 my ($cache, $key, $code) = @_;
388 my $data = $cache->compute($key, $code);
391 # use ->compute_fh($key, $code_fh) interface
392 sub cache_compute_fh
{
393 my ($cache, $key, $code_fh) = @_;
395 my ($fh, $filename) = $cache->compute_fh($key, $code_fh);
401 # from http://aaroncrane.co.uk/talks/pipes_and_processes/
403 my ($child_process_code) = @_;
406 die "Failed to fork: $!\n" if !defined $pid;
408 return $pid if $pid != 0;
410 # Now we're in the new child process
411 $child_process_code->();
415 sub parallel_run
(&) {
416 my $child_code = shift;
420 my (%pid_for_child, %fd_for_child);
421 my $sel = IO
::Select
->new();
422 foreach my $child_idx (1..$nchildren) {
423 my $pipe = IO
::Pipe
->new()
424 or die "Failed to create pipe: $!\n";
426 my $pid = fork_child
{
428 or die "$$: Child \$pipe->writer(): $!\n";
429 dup2
(fileno($pipe), fileno(STDOUT
))
430 or die "$$: Child $child_idx failed to reopen stdout to pipe: $!\n";
432 or die "$$: Child $child_idx failed to close pipe: $!\n";
434 # From Test-Simple-0.96/t/subtest/fork.t
436 # Force all T::B output into the pipe (redirected to STDOUT),
437 # for the parent builder as well as the current subtest builder.
439 no warnings
'redefine';
440 *Test
::Builder
::output
= sub { *STDOUT
};
441 *Test
::Builder
::failure_output
= sub { *STDOUT
};
442 *Test
::Builder
::todo_output
= sub { *STDOUT
};
451 $pid_for_child{$pid} = $child_idx;
453 or die "Failed to \$pipe->reader(): $!\n";
454 $fd_for_child{$pipe} = $child_idx;
457 $children{$child_idx} = {
464 while (my @ready = $sel->can_read()) {
465 foreach my $fh (@ready) {
467 my $nread = sysread($fh, $buf, 1024);
469 exists $fd_for_child{$fh}
470 or die "Cannot find child for fd: $fh\n";
473 $children{$fd_for_child{$fh}}{'output'} .= $buf;
480 while (%pid_for_child) {
481 my $pid = waitpid -1, 0;
482 warn "Child $pid_for_child{$pid} ($pid) failed with status: $?\n"
484 delete $pid_for_child{$pid};
487 return map { $children{$_}{'output'} } keys %children;