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         $cache->set_generating_info_is_safe(1);
 337
 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);
 342                 print $data;
 343         };
 344         # returning stale data works
 345         is_deeply(
 346                 \@output,
 347                 [ ($stale_value) x 2 ],
 348                 'background: stale data returned by both process when expired'
 349         );
 350
 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');
 356
 357
 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;
 364 #               print "$sep";
 365 #               print "$eval_error" if defined $eval_error;
 366 #       };
 367 #  TODO: {
 368 #               local $TODO = 'not implemented';
 369 #
 370 #               is_deeply(
 371 #                       [sort @output],
 372 #                       [sort ("$value${sep}", "${sep}get_value_die_once\n")],
 373 #                       'return non-stale value, even if process regenerating it died'
 374 #               );
 375 #
 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');
 379 #       };
 380 #       unlink($lock_file);
 381
 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
 385
 386         @output = parallel_run {
 387                 my $data = cache_compute($cache, $key, \&get_value_slow);
 388                 print $data;
 389         };
 390         # no returning stale data
 391         ok(!scalar(grep { $_ eq $stale_value } @output),
 392            'no stale data if configured');
 393
 394
 395         done_testing();
 396 };
 397 $cache->set_expires_in(-1);
 398
 399
 400 # Test 'generating_info' feature
 401 #
 402 $cache->remove($key);
 403 my $progress_info = "Generating...";
 404 sub test_generating_info {
 405         local $| = 1;
 406         print "$progress_info";
 407 }
 408 $cache->set_generating_info(\&test_generating_info);
 409
 410 subtest 'generating progress info' => sub {
 411         my @progress;
 412
 413         # without background generation
 414         $cache->set_background_cache(0);
 415         $cache->remove($key);
 416
 417         @output = parallel_run {
 418                 my $data = cache_compute($cache, $key, \&get_value_slow);
 419                 print "$sep$data";
 420         };
 421         @progress = map { s/^(.*)\Q${sep}\E//o && $1 } @output;
 422         is_deeply(
 423                 [sort @progress],
 424                 [sort ('', $progress_info)],
 425                 'no background: one process waiting for data prints progress info'
 426         );
 427         is_deeply(
 428                 \@output,
 429                 [ ($value) x 2 ],
 430                 'no background: both processes return correct value'
 431         );
 432
 433
 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);
 440                 print "$sep$data";
 441         };
 442         is_deeply(
 443                 [sort @output],
 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);
 450
 451
 452         # with background generation
 453         $cache->set_background_cache(1);
 454         $cache->remove($key);
 455
 456         @output = parallel_run {
 457                 my $data = cache_compute($cache, $key, \&get_value_slow);
 458                 print "$sep$data";
 459         };
 460         @progress = map { s/^(.*)\Q${sep}\E//o && $1 } @output;
 461         is_deeply(
 462                 \@progress,
 463                 [ ($progress_info) x 2],
 464                 'background: both process print progress info'
 465         );
 466         is_deeply(
 467                 \@output,
 468                 [ ($value) x 2 ],
 469                 'background: both processes return correct value'
 470         );
 471
 472
 473         done_testing();
 474 };
 475 $cache->set_expires_in(-1);
 476
 477
 478 done_testing();
 479
 480
 481 #######################################################################
 482 #######################################################################
 483 #######################################################################
 484
 485 # use ->get($key) and ->set($key, $data) interface
 486 sub cache_get_set {
 487         my ($cache, $key, $code) = @_;
 488
 489         my $data = $cache->get($key);
 490         if (!defined $data) {
 491                 $data = $code->();
 492                 $cache->set($key, $data);
 493         }
 494
 495         return $data;
 496 }
 497
 498 # use ->compute($key, $code) interface
 499 sub cache_compute {
 500         my ($cache, $key, $code) = @_;
 501
 502         my $data = $cache->compute($key, $code);
 503         return $data;
 504 }
 505 # use ->compute_fh($key, $code_fh) interface
 506 sub cache_compute_fh {
 507         my ($cache, $key, $code_fh) = @_;
 508
 509         my ($fh, $filename) = $cache->compute_fh($key, $code_fh);
 510
 511         local $/ = undef;
 512         return <$fh>;
 513 }
 514
 515 # from http://aaroncrane.co.uk/talks/pipes_and_processes/
 516 sub fork_child (&) {
 517         my ($child_process_code) = @_;
 518
 519         my $pid = fork();
 520         die "Failed to fork: $!\n" if !defined $pid;
 521
 522         return $pid if $pid != 0;
 523
 524         # Now we're in the new child process
 525         $child_process_code->();
 526         exit;
 527 }
 528
 529 sub parallel_run (&) {
 530         my $child_code = shift;
 531         my $nchildren = 2;
 532
 533         my %children;
 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";
 539
 540                 my $pid = fork_child {
 541                         $pipe->writer()
 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";
 545                         close $pipe
 546                                 or die "$$: Child $child_idx failed to close pipe: $!\n";
 547
 548                         # From Test-Simple-0.96/t/subtest/fork.t
 549                         #
 550                         # Force all T::B output into the pipe (redirected to STDOUT),
 551                         # for the parent builder as well as the current subtest builder.
 552                         {
 553                                 no warnings 'redefine';
 554                                 *Test::Builder::output         = sub { *STDOUT };
 555                                 *Test::Builder::failure_output = sub { *STDOUT };
 556                                 *Test::Builder::todo_output    = sub { *STDOUT };
 557                         }
 558
 559                         $child_code->();
 560
 561                         *STDOUT->flush();
 562                         close(STDOUT);
 563                 };
 564
 565                 $pid_for_child{$pid} = $child_idx;
 566                 $pipe->reader()
 567                         or die "Failed to \$pipe->reader(): $!\n";
 568                 $fd_for_child{$pipe} = $child_idx;
 569                 $sel->add($pipe);
 570
 571                 $children{$child_idx} = {
 572                         'pid'    => $pid,
 573                         'stdout' => $pipe,
 574                         'output' => '',
 575                 };
 576         }
 577
 578         while (my @ready = $sel->can_read()) {
 579                 foreach my $fh (@ready) {
 580                         my $buf = '';
 581                         my $nread = sysread($fh, $buf, 1024);
 582
 583                         exists $fd_for_child{$fh}
 584                                 or die "Cannot find child for fd: $fh\n";
 585
 586                         if ($nread > 0) {
 587                                 $children{$fd_for_child{$fh}}{'output'} .= $buf;
 588                         } else {
 589                                 $sel->remove($fh);
 590                         }
 591                 }
 592         }
 593
 594         while (%pid_for_child) {
 595                 my $pid = waitpid -1, 0;
 596                 warn "Child $pid_for_child{$pid} ($pid) failed with status: $?\n"
 597                         if $? != 0;
 598                 delete $pid_for_child{$pid};
 599         }
 600
 601         return map { $children{$_}{'output'} } keys %children;
 602 }
 603
 604 __END__