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         'background_cache' => 0,
  28 } ]);
  29 isa_ok($cache, 'GitwebCache::SimpleFileCache');
  30
  31 # compute can fork, don't generate zombies
  32 #local $SIG{CHLD} = 'IGNORE';
  33
  34 # Test that default values are defined
  35 #
  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');
  40
  41 # Test accessors and default values for cache
  42 #
  43 SKIP: {
  44         skip 'default values not defined', 3
  45                 unless ($GitwebCache::SimpleFileCache::DEFAULT_CACHE_ROOT &&
  46                         $GitwebCache::SimpleFileCache::DEFAULT_CACHE_DEPTH);
  47
  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");
  53 }
  54
  55 # ----------------------------------------------------------------------
  56 # CACHE API
  57
  58 # Test the getting, setting, and removal of a cached value
  59 # (Cache::Cache interface)
  60 #
  61 my $key = 'Test Key';
  62 my $value = 'Test Value';
  63
  64 subtest 'Cache::Cache interface' => sub {
  65         foreach my $method (qw(get set remove)) {
  66                 can_ok($cache, $method);
  67         }
  68
  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');
  72         $cache->remove($key);
  73         ok(!defined($cache->get($key)),        'get after remove, is undefined');
  74
  75         eval { $cache->remove('Not-Existent Key'); };
  76         ok(!$@,                                'remove on non-existent key doesn\'t die');
  77         diag($@) if $@;
  78
  79         done_testing();
  80 };
  81
  82 # Test the getting and setting of a cached value
  83 # (CHI interface)
  84 #
  85 my $call_count = 0;
  86 sub get_value {
  87         $call_count++;
  88         return $value;
  89 }
  90 subtest 'CHI interface' => sub {
  91         can_ok($cache, qw(compute));
  92
  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');
  97
  98         done_testing();
  99 };
 100
 101 # Test the getting and setting of a cached value
 102 # (compute_fh interface)
 103 #
 104 $call_count = 0;
 105 sub write_value {
 106         my $fh = shift;
 107         $call_count++;
 108         print {$fh} $value;
 109 }
 110 subtest 'compute_fh interface' => sub {
 111         can_ok($cache, qw(compute_fh));
 112
 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');
 121
 122         done_testing();
 123 };
 124
 125 # Test cache expiration
 126 #
 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)');
 131
 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)');
 135
 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');
 140
 141         done_testing();
 142 };
 143
 144 # Test assertions for adaptive cache expiration
 145 #
 146 my $load = 0.0;
 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');
 159
 160         $load = 0.0;
 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');
 165
 166         $load = 1_000;
 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');
 171
 172         done_testing();
 173 };
 174
 175 $cache->set_expires_in(-1);
 176
 177 # ----------------------------------------------------------------------
 178 # CONCURRENT ACCESS
 179 sub parallel_run (&); # forward declaration of prototype
 180
 181 # Test 'stampeding herd' / 'cache miss stampede' problem
 182 #
 183
 184 my $slow_time = 1; # how many seconds to sleep in mockup of slow generation
 185 sub get_value_slow {
 186         $call_count++;
 187         sleep $slow_time;
 188         return $value;
 189 }
 190 sub get_value_slow_fh {
 191         my $fh = shift;
 192
 193         $call_count++;
 194         sleep $slow_time;
 195         print {$fh} $value;
 196 }
 197
 198 sub get_value_die {
 199         $call_count++;
 200         die "get_value_die\n";
 201 }
 202
 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)) {
 206                 close $fh;
 207                 die "get_value_die_once\n";
 208         } else {
 209                 sleep $slow_time;
 210                 return $value;
 211         }
 212 }
 213
 214 my @output;
 215 my $sep = '|';
 216 my $total_count = 0;
 217
 218 note("Following tests contain artifical delay of $slow_time seconds");
 219 subtest 'parallel access' => sub {
 220         $cache->remove($key);
 221         @output = parallel_run {
 222                 $call_count = 0;
 223                 my $data = cache_get_set($cache, $key, \&get_value_slow);
 224                 print "$data$sep$call_count";
 225         };
 226         $total_count = 0;
 227         foreach (@output) {
 228                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 229                 #is($child_out, $value, "get/set (parallel) returns '$value'");
 230                 $total_count += $child_count;
 231         }
 232         cmp_ok($total_count, '==', 2, 'parallel get/set: get_value_slow() called twice');
 233
 234         $cache->remove($key);
 235         @output = parallel_run {
 236                 $call_count = 0;
 237                 my $data = cache_compute($cache, $key, \&get_value_slow);
 238                 print "$data$sep$call_count";
 239         };
 240         $total_count = 0;
 241         foreach (@output) {
 242                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 243                 #is($child_out, $value, "compute (parallel) returns '$value'");
 244                 $total_count += $child_count;
 245         }
 246         cmp_ok($total_count, '==', 1, 'parallel compute: get_value_slow() called once');
 247
 248         $cache->remove($key);
 249         @output = parallel_run {
 250                 $call_count = 0;
 251                 my $data = cache_compute_fh($cache, $key, \&get_value_slow_fh);
 252                 print "$data$sep$call_count";
 253         };
 254         $total_count = 0;
 255         foreach (@output) {
 256                 my ($child_out, $child_count) = split(quotemeta $sep, $_);
 257                 #is($child_out, $value, "compute_fh (parallel) returns '$value'");
 258                 $total_count += $child_count;
 259         }
 260         cmp_ok($total_count, '==', 1, 'parallel compute_fh: get_value_slow_fh() called once');
 261
 262         eval {
 263                 local $SIG{ALRM} = sub { die "alarm\n"; };
 264                 alarm 4*$slow_time;
 265
 266                 @output = parallel_run {
 267                         $call_count = 0;
 268                         my $data = eval { cache_compute($cache, 'No Key', \&get_value_die); };
 269                         my $eval_error = $@;
 270                         print "$data" if defined $data;
 271                         print "$sep";
 272                         print "$eval_error" if defined $eval_error;
 273                 };
 274                 is_deeply(
 275                         \@output,
 276                         [ ( "${sep}get_value_die\n" ) x 2 ],
 277                         'parallel compute: get_value_die() died in both'
 278                 );
 279
 280                 alarm 0;
 281         };
 282         ok(!$@, 'parallel compute: no alarm call (neither process hung)');
 283         diag($@) if $@;
 284
 285         $cache->remove($key);
 286         unlink($lock_file);
 287         @output = parallel_run {
 288                 my $data = eval { cache_compute($cache, $key, \&get_value_die_once); };
 289                 my $eval_error = $@;
 290                 print "$data" if defined $data;
 291                 print "$sep";
 292                 print "$eval_error" if defined $eval_error;
 293         };
 294         is_deeply(
 295                 [sort @output],
 296                 [sort ("$value$sep", "${sep}get_value_die_once\n")],
 297                 'parallel compute: return correct value even if other process died'
 298         );
 299         unlink($lock_file);
 300
 301         done_testing();
 302 };
 303
 304 # Test that cache returns stale data in existing but expired cache situation
 305 # (probably should be run only if GIT_TEST_LONG)
 306 #
 307 my $stale_value = 'Stale Value';
 308
 309 subtest 'serving stale data when (re)generating' => sub {
 310         # without background generation
 311         $cache->set_background_cache(0);
 312
 313         $cache->set($key, $stale_value);
 314         $call_count = 0;
 315         $cache->set_expires_in(0);    # expire now
 316         $cache->set_max_lifetime(-1); # forever (always serve stale data)
 317
 318         @output = parallel_run {
 319                 my $data = cache_compute($cache, $key, \&get_value_slow);
 320                 print $data;
 321         };
 322         # returning stale data works
 323         is_deeply(
 324                 [sort @output],
 325                 [sort ($value, $stale_value)],
 326                 'no background: stale data returned by one process'
 327         );
 328
 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');
 332
 333
 334         # with background generation
 335         $cache->set_background_cache(1);
 336
 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);
 341                 print $data;
 342         };
 343         # returning stale data works
 344         is_deeply(
 345                 \@output,
 346                 [ ($stale_value) x 2 ],
 347                 'background: stale data returned by both process when expired'
 348         );
 349
 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');
 355
 356
 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;
 363 #               print "$sep";
 364 #               print "$eval_error" if defined $eval_error;
 365 #       };
 366 #  TODO: {
 367 #               local $TODO = 'not implemented';
 368 #
 369 #               is_deeply(
 370 #                       [sort @output],
 371 #                       [sort ("$value${sep}", "${sep}get_value_die_once\n")],
 372 #                       'return non-stale value, even if process regenerating it died'
 373 #               );
 374 #
 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');
 378 #       };
 379 #       unlink($lock_file);
 380
 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
 384
 385         @output = parallel_run {
 386                 my $data = cache_compute($cache, $key, \&get_value_slow);
 387                 print $data;
 388         };
 389         # no returning stale data
 390         ok(!scalar(grep { $_ eq $stale_value } @output),
 391            'no stale data if configured');
 392
 393
 394         done_testing();
 395 };
 396 $cache->set_expires_in(-1);
 397
 398
 399 # Test 'generating_info' feature
 400 #
 401 $cache->remove($key);
 402 my $progress_info = "Generating...";
 403 sub test_generating_info {
 404         local $| = 1;
 405         print "$progress_info";
 406 }
 407 $cache->set_generating_info(\&test_generating_info);
 408
 409 subtest 'generating progress info' => sub {
 410         my @progress;
 411
 412         # without background generation
 413         $cache->set_background_cache(0);
 414         $cache->remove($key);
 415
 416         @output = parallel_run {
 417                 my $data = cache_compute($cache, $key, \&get_value_slow);
 418                 print "$sep$data";
 419         };
 420         @progress = map { s/^(.*)\Q${sep}\E//o && $1 } @output;
 421         is_deeply(
 422                 [sort @progress],
 423                 [sort ('', $progress_info)],
 424                 'no background: one process waiting for data prints progress info'
 425         );
 426         is_deeply(
 427                 \@output,
 428                 [ ($value) x 2 ],
 429                 'no background: both processes return correct value'
 430         );
 431
 432
 433         # without background generation, with stale value
 434         $cache->set($key, $stale_value);
 435         $cache->set_expires_in(0);    # set value is now expired
 436         $cache->set_max_lifetime(-1); # stale data never expire
 437         @output = parallel_run {
 438                 my $data = cache_compute($cache, $key, \&get_value_slow);
 439                 print "$sep$data";
 440         };
 441         is_deeply(
 442                 [sort @output],
 443         ## no progress for generating process without background generation;
 444         #       [sort ("$progress_info$sep$value", "$sep$stale_value")],
 445                 [sort ("$sep$value", "$sep$stale_value")],
 446                 'no background, stale data: generating gets data, other gets stale data'
 447         ) or diag('@output is ', join ", ", sort @output);
 448         $cache->set_expires_in(-1);
 449
 450
 451         # with background generation
 452         $cache->set_background_cache(1);
 453         $cache->remove($key);
 454
 455         @output = parallel_run {
 456                 my $data = cache_compute($cache, $key, \&get_value_slow);
 457                 print "$sep$data";
 458         };
 459         @progress = map { s/^(.*)\Q${sep}\E//o && $1 } @output;
 460         is_deeply(
 461                 \@progress,
 462                 [ ($progress_info) x 2],
 463                 'background: both process print progress info'
 464         );
 465         is_deeply(
 466                 \@output,
 467                 [ ($value) x 2 ],
 468                 'background: both processes return correct value'
 469         );
 470
 471
 472         done_testing();
 473 };
 474 $cache->set_expires_in(-1);
 475
 476
 477 done_testing();
 478
 479
 480 #######################################################################
 481 #######################################################################
 482 #######################################################################
 483
 484 # use ->get($key) and ->set($key, $data) interface
 485 sub cache_get_set {
 486         my ($cache, $key, $code) = @_;
 487
 488         my $data = $cache->get($key);
 489         if (!defined $data) {
 490                 $data = $code->();
 491                 $cache->set($key, $data);
 492         }
 493
 494         return $data;
 495 }
 496
 497 # use ->compute($key, $code) interface
 498 sub cache_compute {
 499         my ($cache, $key, $code) = @_;
 500
 501         my $data = $cache->compute($key, $code);
 502         return $data;
 503 }
 504 # use ->compute_fh($key, $code_fh) interface
 505 sub cache_compute_fh {
 506         my ($cache, $key, $code_fh) = @_;
 507
 508         my ($fh, $filename) = $cache->compute_fh($key, $code_fh);
 509
 510         local $/ = undef;
 511         return <$fh>;
 512 }
 513
 514 # from http://aaroncrane.co.uk/talks/pipes_and_processes/
 515 sub fork_child (&) {
 516         my ($child_process_code) = @_;
 517
 518         my $pid = fork();
 519         die "Failed to fork: $!\n" if !defined $pid;
 520
 521         return $pid if $pid != 0;
 522
 523         # Now we're in the new child process
 524         $child_process_code->();
 525         exit;
 526 }
 527
 528 sub parallel_run (&) {
 529         my $child_code = shift;
 530         my $nchildren = 2;
 531
 532         my %children;
 533         my (%pid_for_child, %fd_for_child);
 534         my $sel = IO::Select->new();
 535         foreach my $child_idx (1..$nchildren) {
 536                 my $pipe = IO::Pipe->new()
 537                         or die "Failed to create pipe: $!\n";
 538
 539                 my $pid = fork_child {
 540                         $pipe->writer()
 541                                 or die "$$: Child \$pipe->writer(): $!\n";
 542                         dup2(fileno($pipe), fileno(STDOUT))
 543                                 or die "$$: Child $child_idx failed to reopen stdout to pipe: $!\n";
 544                         close $pipe
 545                                 or die "$$: Child $child_idx failed to close pipe: $!\n";
 546
 547                         # From Test-Simple-0.96/t/subtest/fork.t
 548                         #
 549                         # Force all T::B output into the pipe (redirected to STDOUT),
 550                         # for the parent builder as well as the current subtest builder.
 551                         {
 552                                 no warnings 'redefine';
 553                                 *Test::Builder::output         = sub { *STDOUT };
 554                                 *Test::Builder::failure_output = sub { *STDOUT };
 555                                 *Test::Builder::todo_output    = sub { *STDOUT };
 556                         }
 557
 558                         $child_code->();
 559
 560                         *STDOUT->flush();
 561                         close(STDOUT);
 562                 };
 563
 564                 $pid_for_child{$pid} = $child_idx;
 565                 $pipe->reader()
 566                         or die "Failed to \$pipe->reader(): $!\n";
 567                 $fd_for_child{$pipe} = $child_idx;
 568                 $sel->add($pipe);
 569
 570                 $children{$child_idx} = {
 571                         'pid'    => $pid,
 572                         'stdout' => $pipe,
 573                         'output' => '',
 574                 };
 575         }
 576
 577         while (my @ready = $sel->can_read()) {
 578                 foreach my $fh (@ready) {
 579                         my $buf = '';
 580                         my $nread = sysread($fh, $buf, 1024);
 581
 582                         exists $fd_for_child{$fh}
 583                                 or die "Cannot find child for fd: $fh\n";
 584
 585                         if ($nread > 0) {
 586                                 $children{$fd_for_child{$fh}}{'output'} .= $buf;
 587                         } else {
 588                                 $sel->remove($fh);
 589                         }
 590                 }
 591         }
 592
 593         while (%pid_for_child) {
 594                 my $pid = waitpid -1, 0;
 595                 warn "Child $pid_for_child{$pid} ($pid) failed with status: $?\n"
 596                         if $? != 0;
 597                 delete $pid_for_child{$pid};
 598         }
 599
 600         return map { $children{$_}{'output'} } keys %children;
 601 }
 602
 603 __END__