The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

GOZER / mod_perl-2.0.0-RC2-XMas / ModPerl-Registry / t / closure.t 

            

              
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

              
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;
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;
}