t/t9503/test_cache_interface.pl

   1 #!/usr/bin/perl
   2 use lib (split(/:/, $ENV{GITPERLLIB}));
   3
   4 use warnings;
   5 use strict;
   6
   7 use POSIX qw(dup2);
   8 use Fcntl qw(:DEFAULT);
   9 use IO::Handle;
  10 use IO::Select;
  11 use IO::Pipe;
  12
  13 use Test::More;
  14
  15 # test source version
  16 use lib $ENV{GITWEBLIBDIR} || "$ENV{GIT_BUILD_DIR}/gitweb/lib";
  17
  18
  19 # Test creating a cache
  20 #
  21 BEGIN { use_ok('GitwebCache::FileCacheWithLocking'); }
  22 diag("Using lib '$INC[0]'");
  23 diag("Testing '$INC{'GitwebCache/FileCacheWithLocking.pm'}'");
  24
  25 my $cache = new_ok('GitwebCache::FileCacheWithLocking');
  26 isa_ok($cache, 'GitwebCache::SimpleFileCache');
  27
  28 # Test that default values are defined
  29 #
  30 ok(defined $GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT,
  31         '$DEFAULT_CACHE_ROOT defined');
  32 ok(defined $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH,
  33         '$DEFAULT_CACHE_DEPTH defined');
  34
  35 # Test accessors and default values for cache
  36 #
  37 SKIP: {
  38         skip 'default values not defined', 3
  39                 unless ($GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT &&
  40                         $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH);
  41
  42         is($cache->get_namespace(), '', "default namespace is ''");
  43         cmp_ok($cache->get_root(),  'eq', $GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT,
  44                 "default cache root is '$GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT'");
  45         cmp_ok($cache->get_depth(), '==', $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH,
  46                 "default cache depth is $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH");
  47 }
  48
  49 # ----------------------------------------------------------------------
  50 # CACHE API
  51
  52 # Test the getting, setting, and removal of a cached value
  53 # (Cache::Cache interface)
  54 #
  55 my $key = 'Test Key';
  56 my $value = 'Test Value';
  57
  58 subtest 'Cache::Cache interface' => sub {
  59         foreach my $method (qw(get set remove)) {
  60                 can_ok($cache, $method);
  61         }
  62
  63         $cache->set($key, $value);
  64         cmp_ok($cache->get_size($key), '>', 0, 'get_size after set, is greater than 0');
  65         is($cache->get($key), $value,          'get after set, returns cached value');
  66         $cache->remove($key);
  67         ok(!defined($cache->get($key)),        'get after remove, is undefined');
  68
  69         eval { $cache->remove('Not-Existent Key'); };
  70         ok(!$@,                                'remove on non-existent key doesn\'t die');
  71         diag($@) if $@;
  72
  73         done_testing();
  74 };
  75
  76 # Test the getting and setting of a cached value
  77 # (CHI interface)
  78 #
  79 my $call_count = 0;
  80 sub get_value {
  81         $call_count++;
  82         return $value;
  83 }
  84 subtest 'CHI interface' => sub {
  85         can_ok($cache, qw(compute));
  86
  87         is($cache->compute($key, \&get_value), $value, "compute 1st time (set) returns '$value'");
  88         is($cache->compute($key, \&get_value), $value, "compute 2nd time (get) returns '$value'");
  89         is($cache->compute($key, \&get_value), $value, "compute 3rd time (get) returns '$value'");
  90         cmp_ok($call_count, '==', 1, 'get_value() is called once from compute');
  91
  92         done_testing();
  93 };
  94
  95 # Test the getting and setting of a cached value
  96 # (compute_fh interface)
  97 #
  98 $call_count = 0;
  99 sub write_value {
 100         my $fh = shift;
 101         $call_count++;
 102         print {$fh} $value;
 103 }
 104 subtest 'compute_fh interface' => sub {
 105         can_ok($cache, qw(compute_fh));
 106
 107         $cache->remove($key);
 108         is(cache_compute_fh($cache, $key, \&write_value), $value,
 109            "compute_fh 1st time (set) returns '$value'");
 110         is(cache_compute_fh($cache, $key, \&write_value), $value,
 111            "compute_fh 2nd time (get) returns '$value'");
 112         is(cache_compute_fh($cache, $key, \&write_value), $value,
 113            "compute_fh 3rd time (get) returns '$value'");
 114         cmp_ok($call_count, '==', 1, 'write_value() is called once from compute_fh');
 115
 116         done_testing();
 117 };
 118
 119 # Test cache expiration
 120 #
 121 subtest 'cache expiration' => sub {
 122         $cache->set_expires_in(60*60*24); # set expire time to 1 day
 123         cmp_ok($cache->get_expires_in(), '>', 0, '"expires in" is greater than 0');
 124         is($cache->get($key), $value,            'get returns cached value (not expired in 1d)');
 125
 126         $cache->set_expires_in(-1); # set expire time to never expire
 127         is($cache->get_expires_in(), -1,         '"expires in" is set to never (-1)');
 128         is($cache->get($key), $value,            'get returns cached value (not expired)');
 129
 130         $cache->set_expires_in(0);
 131         is($cache->get_expires_in(),  0,         '"expires in" is set to now (0)');
 132         $cache->set($key, $value);
 133         ok(!defined($cache->get($key)),          'cache is expired');
 134
 135         done_testing();
 136 };
 137
 138 # Test assertions for adaptive cache expiration
 139 #
 140 my $load = 0.0;
 141 sub load { return $load; }
 142 my $expires_min = 10;
 143 my $expires_max = 30;
 144 $cache->set_expires_in(-1);
 145 $cache->set_expires_min($expires_min);
 146 $cache->set_expires_max($expires_max);
 147 $cache->set_check_load(\&load);
 148 subtest 'adaptive cache expiration' => sub {
 149         cmp_ok($cache->get_expires_min(), '==', $expires_min,
 150                '"expires min" set correctly');
 151         cmp_ok($cache->get_expires_max(), '==', $expires_max,
 152                '"expires max" set correctly');
 153
 154         $load = 0.0;
 155         cmp_ok($cache->get_expires_in(), '>=', $expires_min,
 156                '"expires in" bound from down for load=0');
 157         cmp_ok($cache->get_expires_in(), '<=', $expires_max,
 158                '"expires in" bound from up   for load=0');
 159
 160         $load = 1_000;
 161         cmp_ok($cache->get_expires_in(), '>=', $expires_min,
 162                '"expires in" bound from down for heavy load');
 163         cmp_ok($cache->get_expires_in(), '<=', $expires_max,
 164                '"expires in" bound from up   for heavy load');
 165
 166         done_testing();
 167 };
 168
 169 $cache->set_expires_in(-1);
 170
 171 # ----------------------------------------------------------------------
 172 # CONCURRENT ACCESS
 173 sub parallel_run (&); # forward declaration of prototype
 174
 175 # Test 'stampeding herd' / 'cache miss stampede' problem
 176 #
 177
 178 my $slow_time = 1; # how many seconds to sleep in mockup of slow generation
 179 sub get_value_slow {
 180         $call_count++;
 181         sleep $slow_time;
 182         return $value;
 183 }
 184 sub get_value_slow_fh {
 185         my $fh = shift;
 186
 187         $call_count++;
 188         sleep $slow_time;
 189         print {$fh} $value;
 190 }
 191
 192 sub get_value_die {
 193         $call_count++;
 194         die "get_value_die\n";
 195 }
 196
 197 my $lock_file = "$0.$$.lock";
 198 sub get_value_die_once {
 199         if (sysopen my $fh, $lock_file, (O_WRONLY | O_CREAT | O_EXCL)) {
 200                 close $fh;
 201                 die "get_value_die_once\n";
 202         } else {
 203                 sleep $slow_time;
 204                 return $value;
 205         }
 206 }
 207
 208 my @output;
 209 my $sep = '|';
 210 my $total_count = 0;
 211
 212 note("Following tests contain artifical delay of $slow_time seconds");
 213 subtest 'parallel access' => sub {
 214         $cache->remove($key);
 215         @output = parallel_run {
 216                 $call_count = 0;
 217                 my $data = cache_get_set($cache, $key, \&get_value_slow);
 218                 print "$data$sep$call_count";
 219         };
 220         $total_count = 0;
 221         foreach (@output) {
 222                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 223                 #is($child_out, $value, "get/set (parallel) returns '$value'");
 224                 $total_count += $child_count;
 225         }
 226         cmp_ok($total_count, '==', 2, 'parallel get/set: get_value_slow() called twice');
 227
 228         $cache->remove($key);
 229         @output = parallel_run {
 230                 $call_count = 0;
 231                 my $data = cache_compute($cache, $key, \&get_value_slow);
 232                 print "$data$sep$call_count";
 233         };
 234         $total_count = 0;
 235         foreach (@output) {
 236                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 237                 #is($child_out, $value, "compute (parallel) returns '$value'");
 238                 $total_count += $child_count;
 239         }
 240         cmp_ok($total_count, '==', 1, 'parallel compute: get_value_slow() called once');
 241
 242         $cache->remove($key);
 243         @output = parallel_run {
 244                 $call_count = 0;
 245                 my $data = cache_compute_fh($cache, $key, \&get_value_slow_fh);
 246                 print "$data$sep$call_count";
 247         };
 248         $total_count = 0;
 249         foreach (@output) {
 250                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 251                 #is($child_out, $value, "compute_fh (parallel) returns '$value'");
 252                 $total_count += $child_count;
 253         }
 254         cmp_ok($total_count, '==', 1, 'parallel compute_fh: get_value_slow_fh() called once');
 255
 256         eval {
 257                 local $SIG{ALRM} = sub { die "alarm\n"; };
 258                 alarm 4*$slow_time;
 259
 260                 @output = parallel_run {
 261                         $call_count = 0;
 262                         my $data = eval { cache_compute($cache, 'No Key', \&get_value_die); };
 263                         my $eval_error = $@;
 264                         print "$data" if defined $data;
 265                         print "$sep";
 266                         print "$eval_error" if defined $eval_error;
 267                 };
 268                 is_deeply(
 269                         \@output,
 270                         [ ( "${sep}get_value_die\n" ) x 2 ],
 271                         'parallel compute: get_value_die() died in both'
 272                 );
 273
 274                 alarm 0;
 275         };
 276         ok(!$@, 'parallel compute: no alarm call (neither process hung)');
 277         diag($@) if $@;
 278
 279         $cache->remove($key);
 280         unlink($lock_file);
 281         @output = parallel_run {
 282                 my $data = eval { cache_compute($cache, $key, \&get_value_die_once); };
 283                 my $eval_error = $@;
 284                 print "$data" if defined $data;
 285                 print "$sep";
 286                 print "$eval_error" if defined $eval_error;
 287         };
 288         is_deeply(
 289                 [sort @output],
 290                 [sort ("$value$sep", "${sep}get_value_die_once\n")],
 291                 'parallel compute: return correct value even if other process died'
 292         );
 293         unlink($lock_file);
 294
 295         done_testing();
 296 };
 297
 298 done_testing();
 299
 300
 301 #######################################################################
 302 #######################################################################
 303 #######################################################################
 304
 305 # use ->get($key) and ->set($key, $data) interface
 306 sub cache_get_set {
 307         my ($cache, $key, $code) = @_;
 308
 309         my $data = $cache->get($key);
 310         if (!defined $data) {
 311                 $data = $code->();
 312                 $cache->set($key, $data);
 313         }
 314
 315         return $data;
 316 }
 317
 318 # use ->compute($key, $code) interface
 319 sub cache_compute {
 320         my ($cache, $key, $code) = @_;
 321
 322         my $data = $cache->compute($key, $code);
 323         return $data;
 324 }
 325 # use ->compute_fh($key, $code_fh) interface
 326 sub cache_compute_fh {
 327         my ($cache, $key, $code_fh) = @_;
 328
 329         my ($fh, $filename) = $cache->compute_fh($key, $code_fh);
 330
 331         local $/ = undef;
 332         return <$fh>;
 333 }
 334
 335 # from http://aaroncrane.co.uk/talks/pipes_and_processes/
 336 sub fork_child (&) {
 337         my ($child_process_code) = @_;
 338
 339         my $pid = fork();
 340         die "Failed to fork: $!\n" if !defined $pid;
 341
 342         return $pid if $pid != 0;
 343
 344         # Now we're in the new child process
 345         $child_process_code->();
 346         exit;
 347 }
 348
 349 sub parallel_run (&) {
 350         my $child_code = shift;
 351         my $nchildren = 2;
 352
 353         my %children;
 354         my (%pid_for_child, %fd_for_child);
 355         my $sel = IO::Select->new();
 356         foreach my $child_idx (1..$nchildren) {
 357                 my $pipe = IO::Pipe->new()
 358                         or die "Failed to create pipe: $!\n";
 359
 360                 my $pid = fork_child {
 361                         $pipe->writer()
 362                                 or die "$$: Child \$pipe->writer(): $!\n";
 363                         dup2(fileno($pipe), fileno(STDOUT))
 364                                 or die "$$: Child $child_idx failed to reopen stdout to pipe: $!\n";
 365                         close $pipe
 366                                 or die "$$: Child $child_idx failed to close pipe: $!\n";
 367
 368                         # From Test-Simple-0.96/t/subtest/fork.t
 369                         #
 370                         # Force all T::B output into the pipe (redirected to STDOUT),
 371                         # for the parent builder as well as the current subtest builder.
 372                         {
 373                                 no warnings 'redefine';
 374                                 *Test::Builder::output         = sub { *STDOUT };
 375                                 *Test::Builder::failure_output = sub { *STDOUT };
 376                                 *Test::Builder::todo_output    = sub { *STDOUT };
 377                         }
 378
 379                         $child_code->();
 380
 381                         *STDOUT->flush();
 382                         close(STDOUT);
 383                 };
 384
 385                 $pid_for_child{$pid} = $child_idx;
 386                 $pipe->reader()
 387                         or die "Failed to \$pipe->reader(): $!\n";
 388                 $fd_for_child{$pipe} = $child_idx;
 389                 $sel->add($pipe);
 390
 391                 $children{$child_idx} = {
 392                         'pid'    => $pid,
 393                         'stdout' => $pipe,
 394                         'output' => '',
 395                 };
 396         }
 397
 398         while (my @ready = $sel->can_read()) {
 399                 foreach my $fh (@ready) {
 400                         my $buf = '';
 401                         my $nread = sysread($fh, $buf, 1024);
 402
 403                         exists $fd_for_child{$fh}
 404                                 or die "Cannot find child for fd: $fh\n";
 405
 406                         if ($nread > 0) {
 407                                 $children{$fd_for_child{$fh}}{'output'} .= $buf;
 408                         } else {
 409                                 $sel->remove($fh);
 410                         }
 411                 }
 412         }
 413
 414         while (%pid_for_child) {
 415                 my $pid = waitpid -1, 0;
 416                 warn "Child $pid_for_child{$pid} ($pid) failed with status: $?\n"
 417                         if $? != 0;
 418                 delete $pid_for_child{$pid};
 419         }
 420
 421         return map { $children{$_}{'output'} } keys %children;
 422 }
 423
 424 __END__