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
|
# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
package TestAPI::server_util;
use strict;
use warnings FATAL => 'all';
use Apache::Test;
use Apache::TestUtil;
use File::Spec::Functions qw(canonpath catfile);
use Apache2::RequestRec ();
use Apache2::ServerRec ();
use Apache2::ServerUtil ();
use Apache2::Process ();
use APR::Pool ();
use Apache2::Const -compile => 'OK';
my $serverroot = Apache::Test::config()->{vars}->{serverroot};
our @ISA = qw(Apache2::RequestRec);
sub new {
my $class = shift;
my $r = shift;
bless { r => $r }, $class;
}
sub handler {
my $r = shift;
plan $r, tests => 17;
{
my $s = $r->server;
my @expected = qw(ModPerl::Test::exit_handler TestExit::FromPerlModule::exit_handler);
my @handlers =
@{ $s->get_handlers('PerlChildExitHandler') || []};
ok t_cmp(scalar(@handlers), scalar(@expected), "get_handlers");
}
t_debug('Apache2::ServerUtil::exists_config_define');
ok Apache2::ServerUtil::exists_config_define('MODPERL2');
ok ! Apache2::ServerUtil::exists_config_define('FOO');
t_debug('registering method FOO');
ok $r->server->method_register('FOO');
server_root_relative_tests($r);
eval { Apache2::ServerUtil::server_shutdown_cleanup_register(
sub { Apache2::Const::OK });
};
my $sub = "server_shutdown_cleanup_register";
ok t_cmp $@, qr/Can't run '$sub' after server startup/,
"can't register server_shutdown cleanup after server startup";
# on start we get 1, and immediate restart gives 2
ok t_cmp Apache2::ServerUtil::restart_count, 2, "restart count";
Apache2::Const::OK;
}
# 11 sub-tests
sub server_root_relative_tests {
my $r = shift;
my %pools = (
'$r->pool' =>
$r->pool,
'$r->connection->pool' =>
$r->connection->pool,
'$r->server->process->pool' =>
$r->server->process->pool,
'$r->server->process->pconf' =>
$r->server->process->pconf,
'Apache2::ServerUtil->server->process->pconf' =>
Apache2::ServerUtil->server->process->pconf,
'APR::Pool->new' =>
APR::Pool->new,
);
# syntax - an object or pool is required
t_debug("Apache2::ServerUtil::server_root_relative() died");
eval { my $dir = Apache2::ServerUtil::server_root_relative() };
t_debug("\$\@: $@");
ok $@;
foreach my $p (keys %pools) {
# we will leak memory here when calling the function with a
# pool whose life is longer than of $r, but it doesn't matter
# for the test
ok t_filepath_cmp(
canonpath(Apache2::ServerUtil::server_root_relative($pools{$p},
'conf')),
catfile($serverroot, 'conf'),
"Apache2::ServerUtil:::server_root_relative($p, 'conf')");
}
# syntax - unrecognized objects don't segfault
{
my $obj = bless {}, 'Apache2::Foo';
eval { Apache2::ServerUtil::server_root_relative($obj, 'conf') };
ok t_cmp($@,
qr/p is not of type APR::Pool/,
"Apache2::ServerUtil::server_root_relative(\$obj, 'conf')");
}
# no file argument gives ServerRoot
{
my $server_root_relative =
Apache2::ServerUtil::server_root_relative($r->pool);
ok t_filepath_cmp(canonpath($server_root_relative),
canonpath($serverroot),
'server_root_relative($pool)');
# Apache2::ServerUtil::server_root is also the ServerRoot constant
ok t_filepath_cmp(canonpath(Apache2::ServerUtil::server_root),
canonpath($server_root_relative),
'Apache2::ServerUtil::server_root');
}
{
# absolute paths should resolve to themselves
my $dir1 = Apache2::ServerUtil::server_root_relative($r->pool, 'logs');
my $dir2 = Apache2::ServerUtil::server_root_relative($r->pool, $dir1);
ok t_filepath_cmp($dir1, $dir2, "absolute path");
}
}
1;
__END__
|
