1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
|
# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
use strict;
use warnings FATAL => 'all';
use Apache::Test;
use Apache::TestUtil;
use Apache::TestRequest;
use TestCommon::SameInterp;
use File::Spec::Functions;
# this test tests how various registry packages cache and flush the
# scripts their run, and whether they check modification on the disk
# or not. We don't test the closure side effect, but we use it as a
# test aid. The tests makes sure that they run through the same
# interpreter all the time (in case that the server is running more
# than one interpreter)
my @modules = qw(registry registry_bb perlrun);
plan tests => 6, need [qw(mod_alias.c HTML::HeadParser)];
my $cfg = Apache::Test::config();
my $file = 'closure.pl';
my $path = catfile $cfg->{vars}->{serverroot}, 'cgi-bin', $file;
my $orig_mtime = (stat($path))[8];
# for all sub-tests in this test, we make sure that we always get onto
# the same interpreter. if this doesn't happen we skip the sub-test or
# a group of them, where several sub-tests rely on each other.
{
# ModPerl::PerlRun
# always flush
# no cache
my $url = "/same_interp/perlrun/$file";
my $same_interp = Apache::TestRequest::same_interp_tie($url);
# should be no closure effect, always returns 1
my $first = same_interp_req_body($same_interp, \&GET, $url);
my $second = same_interp_req_body($same_interp, \&GET, $url);
same_interp_skip_not_found(
(scalar(grep defined, $first, $second) != 2),
$first && $second && ($second - $first),
0,
"never the closure problem",
);
# modify the file
touch_mtime($path);
# it doesn't matter, since the script is not cached anyway
my $third = same_interp_req_body($same_interp, \&GET, $url);
same_interp_skip_not_found(
(scalar(grep defined, $first, $second, $third) != 3),
$third,
1,
"never the closure problem",
);
reset_mtime($path);
}
{
# ModPerl::Registry
# no flush
# cache, but reload on modification
my $url = "/same_interp/registry/$file";
my $same_interp = Apache::TestRequest::same_interp_tie($url);
# we don't know what other test has called this uri before, so we
# check the difference between two subsequent calls. In this case
# the difference should be 1.
my $first = same_interp_req_body($same_interp, \&GET, $url);
my $second = same_interp_req_body($same_interp, \&GET, $url);
same_interp_skip_not_found(
(scalar(grep defined, $first, $second) != 2),
$first && $second && ($second - $first),
1,
"the closure problem should exist",
);
# modify the file
touch_mtime($path);
# should not notice closure effect on the first request
my $third = same_interp_req_body($same_interp, \&GET, $url);
same_interp_skip_not_found(
(scalar(grep defined, $first, $second, $third) != 3),
$third,
1,
"no closure on the first request",
);
reset_mtime($path);
}
{
# ModPerl::RegistryBB
# no flush
# cache once, don't check for mods
my $url = "/same_interp/registry_bb/$file";
my $same_interp = Apache::TestRequest::same_interp_tie($url);
# we don't know what other test has called this uri before, so we
# check the difference between two subsequent calls. In this case
# the difference should be 1.
my $first = same_interp_req_body($same_interp, \&GET, $url);
my $second = same_interp_req_body($same_interp, \&GET, $url);
same_interp_skip_not_found(
(scalar(grep defined, $first, $second) != 2),
$first && $second && ($second - $first),
1,
"the closure problem should exist",
);
# modify the file
touch_mtime($path);
# modification shouldn't be noticed
my $third = same_interp_req_body($same_interp, \&GET, $url);
same_interp_skip_not_found(
(scalar(grep defined, $first, $second, $third) != 3),
$first && $second && $third - $second,
1,
"no reload on modification, the closure problem persists",
);
reset_mtime($path);
}
sub touch_mtime {
my $file = shift;
# push the mtime into the future (at least 2 secs to work on win32)
# so ModPerl::Registry will re-compile the package
my $time = time + 5; # make it 5 to be sure
utime $time, $time, $file;
}
sub reset_mtime {
my $file = shift;
# reset the timestamp to the original mod-time
utime $orig_mtime, $orig_mtime, $file;
}
|