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         'max_lifetime' => 0, # turn it off
  27 } ]);
  28 isa_ok($cache, 'GitwebCache::SimpleFileCache');
  29
  30 # Test that default values are defined
  31 #
  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');
  36
  37 # Test accessors and default values for cache
  38 #
  39 SKIP: {
  40         skip 'default values not defined', 3
  41                 unless ($GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT &&
  42                         $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH);
  43
  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");
  49 }
  50
  51 # ----------------------------------------------------------------------
  52 # CACHE API
  53
  54 # Test the getting, setting, and removal of a cached value
  55 # (Cache::Cache interface)
  56 #
  57 my $key = 'Test Key';
  58 my $value = 'Test Value';
  59
  60 subtest 'Cache::Cache interface' => sub {
  61         foreach my $method (qw(get set remove)) {
  62                 can_ok($cache, $method);
  63         }
  64
  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');
  68         $cache->remove($key);
  69         ok(!defined($cache->get($key)),        'get after remove, is undefined');
  70
  71         eval { $cache->remove('Not-Existent Key'); };
  72         ok(!$@,                                'remove on non-existent key doesn\'t die');
  73         diag($@) if $@;
  74
  75         done_testing();
  76 };
  77
  78 # Test the getting and setting of a cached value
  79 # (CHI interface)
  80 #
  81 my $call_count = 0;
  82 sub get_value {
  83         $call_count++;
  84         return $value;
  85 }
  86 subtest 'CHI interface' => sub {
  87         can_ok($cache, qw(compute));
  88
  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');
  93
  94         done_testing();
  95 };
  96
  97 # Test the getting and setting of a cached value
  98 # (compute_fh interface)
  99 #
 100 $call_count = 0;
 101 sub write_value {
 102         my $fh = shift;
 103         $call_count++;
 104         print {$fh} $value;
 105 }
 106 subtest 'compute_fh interface' => sub {
 107         can_ok($cache, qw(compute_fh));
 108
 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');
 117
 118         done_testing();
 119 };
 120
 121 # Test cache expiration
 122 #
 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)');
 127
 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)');
 131
 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');
 136
 137         done_testing();
 138 };
 139
 140 # Test assertions for adaptive cache expiration
 141 #
 142 my $load = 0.0;
 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');
 155
 156         $load = 0.0;
 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');
 161
 162         $load = 1_000;
 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');
 167
 168         done_testing();
 169 };
 170
 171 $cache->set_expires_in(-1);
 172
 173 # ----------------------------------------------------------------------
 174 # CONCURRENT ACCESS
 175 sub parallel_run (&); # forward declaration of prototype
 176
 177 # Test 'stampeding herd' / 'cache miss stampede' problem
 178 #
 179
 180 my $slow_time = 1; # how many seconds to sleep in mockup of slow generation
 181 sub get_value_slow {
 182         $call_count++;
 183         sleep $slow_time;
 184         return $value;
 185 }
 186 sub get_value_slow_fh {
 187         my $fh = shift;
 188
 189         $call_count++;
 190         sleep $slow_time;
 191         print {$fh} $value;
 192 }
 193
 194 sub get_value_die {
 195         $call_count++;
 196         die "get_value_die\n";
 197 }
 198
 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)) {
 202                 close $fh;
 203                 die "get_value_die_once\n";
 204         } else {
 205                 sleep $slow_time;
 206                 return $value;
 207         }
 208 }
 209
 210 my @output;
 211 my $sep = '|';
 212 my $total_count = 0;
 213
 214 note("Following tests contain artifical delay of $slow_time seconds");
 215 subtest 'parallel access' => sub {
 216         $cache->remove($key);
 217         @output = parallel_run {
 218                 $call_count = 0;
 219                 my $data = cache_get_set($cache, $key, \&get_value_slow);
 220                 print "$data$sep$call_count";
 221         };
 222         $total_count = 0;
 223         foreach (@output) {
 224                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 225                 #is($child_out, $value, "get/set (parallel) returns '$value'");
 226                 $total_count += $child_count;
 227         }
 228         cmp_ok($total_count, '==', 2, 'parallel get/set: get_value_slow() called twice');
 229
 230         $cache->remove($key);
 231         @output = parallel_run {
 232                 $call_count = 0;
 233                 my $data = cache_compute($cache, $key, \&get_value_slow);
 234                 print "$data$sep$call_count";
 235         };
 236         $total_count = 0;
 237         foreach (@output) {
 238                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 239                 #is($child_out, $value, "compute (parallel) returns '$value'");
 240                 $total_count += $child_count;
 241         }
 242         cmp_ok($total_count, '==', 1, 'parallel compute: get_value_slow() called once');
 243
 244         $cache->remove($key);
 245         @output = parallel_run {
 246                 $call_count = 0;
 247                 my $data = cache_compute_fh($cache, $key, \&get_value_slow_fh);
 248                 print "$data$sep$call_count";
 249         };
 250         $total_count = 0;
 251         foreach (@output) {
 252                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 253                 #is($child_out, $value, "compute_fh (parallel) returns '$value'");
 254                 $total_count += $child_count;
 255         }
 256         cmp_ok($total_count, '==', 1, 'parallel compute_fh: get_value_slow_fh() called once');
 257
 258         eval {
 259                 local $SIG{ALRM} = sub { die "alarm\n"; };
 260                 alarm 4*$slow_time;
 261
 262                 @output = parallel_run {
 263                         $call_count = 0;
 264                         my $data = eval { cache_compute($cache, 'No Key', \&get_value_die); };
 265                         my $eval_error = $@;
 266                         print "$data" if defined $data;
 267                         print "$sep";
 268                         print "$eval_error" if defined $eval_error;
 269                 };
 270                 is_deeply(
 271                         \@output,
 272                         [ ( "${sep}get_value_die\n" ) x 2 ],
 273                         'parallel compute: get_value_die() died in both'
 274                 );
 275
 276                 alarm 0;
 277         };
 278         ok(!$@, 'parallel compute: no alarm call (neither process hung)');
 279         diag($@) if $@;
 280
 281         $cache->remove($key);
 282         unlink($lock_file);
 283         @output = parallel_run {
 284                 my $data = eval { cache_compute($cache, $key, \&get_value_die_once); };
 285                 my $eval_error = $@;
 286                 print "$data" if defined $data;
 287                 print "$sep";
 288                 print "$eval_error" if defined $eval_error;
 289         };
 290         is_deeply(
 291                 [sort @output],
 292                 [sort ("$value$sep", "${sep}get_value_die_once\n")],
 293                 'parallel compute: return correct value even if other process died'
 294         );
 295         unlink($lock_file);
 296
 297         done_testing();
 298 };
 299
 300 # Test that cache returns stale data in existing but expired cache situation
 301 # (probably should be run only if GIT_TEST_LONG)
 302 #
 303 my $stale_value = 'Stale Value';
 304
 305 subtest 'serving stale data when (re)generating' => sub {
 306         $cache->set($key, $stale_value);
 307         $call_count = 0;
 308         $cache->set_expires_in(0);    # expire now
 309         $cache->set_max_lifetime(-1); # forever (always serve stale data)
 310
 311         @output = parallel_run {
 312                 my $data = cache_compute($cache, $key, \&get_value_slow);
 313                 print $data;
 314         };
 315         ok(scalar(grep { $_ eq $stale_value } @output),
 316            'stale data in at least one process when expired');
 317
 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');
 321
 322
 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;
 329 #               print "$sep";
 330 #               print "$eval_error" if defined $eval_error;
 331 #       };
 332 #  TODO: {
 333 #               local $TODO = 'not implemented';
 334 #
 335 #               is_deeply(
 336 #                       [sort @output],
 337 #                       [sort ("$value${sep}", "${sep}get_value_die_once\n")],
 338 #                       'return non-stale value, even if process regenerating it died'
 339 #               );
 340 #
 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');
 344 #       };
 345 #       unlink($lock_file);
 346
 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
 350
 351         @output = parallel_run {
 352                 my $data = cache_compute($cache, $key, \&get_value_slow);
 353                 print $data;
 354         };
 355         # no returning stale data
 356         ok(!scalar(grep { $_ eq $stale_value } @output),
 357            'no stale data if configured');
 358
 359
 360         done_testing();
 361 };
 362 $cache->set_expires_in(-1);
 363
 364 done_testing();
 365
 366
 367 #######################################################################
 368 #######################################################################
 369 #######################################################################
 370
 371 # use ->get($key) and ->set($key, $data) interface
 372 sub cache_get_set {
 373         my ($cache, $key, $code) = @_;
 374
 375         my $data = $cache->get($key);
 376         if (!defined $data) {
 377                 $data = $code->();
 378                 $cache->set($key, $data);
 379         }
 380
 381         return $data;
 382 }
 383
 384 # use ->compute($key, $code) interface
 385 sub cache_compute {
 386         my ($cache, $key, $code) = @_;
 387
 388         my $data = $cache->compute($key, $code);
 389         return $data;
 390 }
 391 # use ->compute_fh($key, $code_fh) interface
 392 sub cache_compute_fh {
 393         my ($cache, $key, $code_fh) = @_;
 394
 395         my ($fh, $filename) = $cache->compute_fh($key, $code_fh);
 396
 397         local $/ = undef;
 398         return <$fh>;
 399 }
 400
 401 # from http://aaroncrane.co.uk/talks/pipes_and_processes/
 402 sub fork_child (&) {
 403         my ($child_process_code) = @_;
 404
 405         my $pid = fork();
 406         die "Failed to fork: $!\n" if !defined $pid;
 407
 408         return $pid if $pid != 0;
 409
 410         # Now we're in the new child process
 411         $child_process_code->();
 412         exit;
 413 }
 414
 415 sub parallel_run (&) {
 416         my $child_code = shift;
 417         my $nchildren = 2;
 418
 419         my %children;
 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";
 425
 426                 my $pid = fork_child {
 427                         $pipe->writer()
 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";
 431                         close $pipe
 432                                 or die "$$: Child $child_idx failed to close pipe: $!\n";
 433
 434                         # From Test-Simple-0.96/t/subtest/fork.t
 435                         #
 436                         # Force all T::B output into the pipe (redirected to STDOUT),
 437                         # for the parent builder as well as the current subtest builder.
 438                         {
 439                                 no warnings 'redefine';
 440                                 *Test::Builder::output         = sub { *STDOUT };
 441                                 *Test::Builder::failure_output = sub { *STDOUT };
 442                                 *Test::Builder::todo_output    = sub { *STDOUT };
 443                         }
 444
 445                         $child_code->();
 446
 447                         *STDOUT->flush();
 448                         close(STDOUT);
 449                 };
 450
 451                 $pid_for_child{$pid} = $child_idx;
 452                 $pipe->reader()
 453                         or die "Failed to \$pipe->reader(): $!\n";
 454                 $fd_for_child{$pipe} = $child_idx;
 455                 $sel->add($pipe);
 456
 457                 $children{$child_idx} = {
 458                         'pid'    => $pid,
 459                         'stdout' => $pipe,
 460                         'output' => '',
 461                 };
 462         }
 463
 464         while (my @ready = $sel->can_read()) {
 465                 foreach my $fh (@ready) {
 466                         my $buf = '';
 467                         my $nread = sysread($fh, $buf, 1024);
 468
 469                         exists $fd_for_child{$fh}
 470                                 or die "Cannot find child for fd: $fh\n";
 471
 472                         if ($nread > 0) {
 473                                 $children{$fd_for_child{$fh}}{'output'} .= $buf;
 474                         } else {
 475                                 $sel->remove($fh);
 476                         }
 477                 }
 478         }
 479
 480         while (%pid_for_child) {
 481                 my $pid = waitpid -1, 0;
 482                 warn "Child $pid_for_child{$pid} ($pid) failed with status: $?\n"
 483                         if $? != 0;
 484                 delete $pid_for_child{$pid};
 485         }
 486
 487         return map { $children{$_}{'output'} } keys %children;
 488 }
 489
 490 __END__