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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
# $Id: apache.t,v 1.28 1999/08/26 23:39:52 john Exp $
use strict;
use Cwd;
use IO::Socket;
use Net::Ident;
# GET uri from server
sub GET {
my($server, $uri) = @_;
my($header, $content);
print "# GET http://$server$uri\n";
eval {
my $sock = new IO::Socket::INET PeerAddr => $server,
Timeout => 10;
$sock or die "cannot connect to $server: $!\n";
$sock->autoflush(1);
local $SIG{ALRM} =
sub { die "Timeout in GET\n" };
alarm(10);
print $sock <<HTTP;
GET $uri HTTP/1.0\r
User-Agent: t/apache.t\r
Host: $server\r
Connection: close\r
\r
HTTP
my $resp = join("", <$sock>);
alarm(0);
($header, $content) = $resp =~ /\A((?:.*\n)+)\r?\n([\s\S]*)\Z/;
$header or die "server returned garbage: $resp\n";
wantarray ? ($content, $header) : $content;
};
}
use vars qw($apache_bin $apache_addr $apache_root $username $ourpid);
END {
# make sure apache dies when we exit, but only if we exit ourselves
return if ! $ourpid || $ourpid != $$;
if ( defined $apache_root &&
-r "$apache_root/logs/httpd.pid" &&
open(PID, "$apache_root/logs/httpd.pid") )
{
my $pid = <PID>;
chomp $pid;
close PID;
kill TERM => $pid and
print "# stopped apache\n";
sleep 2;
kill KILL => $pid;
}
}
# Initialise apache test. If the below dies at any point, it means the
# apache setup failed. This does NOT fail the test, however...
eval {
# get current directory
my $cwd = cwd();
# set our PID, for the END{} routine
$ourpid = $$;
# verify the apache test is configured
-f "$cwd/t/apache/conf/apache_config.pl" or
die "Apache test not configured\n";
# read configuration data
require "$cwd/t/apache/conf/apache_config.pl";
# write file containing current @INC, to be used by the apache
# mod_perl programs.
open(INC, ">$apache_root/perl/inc") or
die "cannot write $apache_root/perl/inc: $!\n";
print INC '@INC = ("',
join('","',
map {
s/^\./$cwd/;
$_ = "$cwd/$_" unless m-^/-;
s/\\/\\\\/g;
s/"/\\"/g;
$_
} @INC),
"\");\n";
close INC;
# OK! Let's have fun!
print "# Starting apache...\n";
system($apache_bin, "-f", "$apache_root/conf/httpd.conf") and
die "Apache returned non-zero exit status: $?\n";
my $startuptime = 3 + time;
# do a really silly loopback connection and ident lookup on this
# to find out what identd returns. We assume previous tests
# already established the proper functioning of Net::Ident in
# "normal" circumstances!
my $listen = new IO::Socket::INET Listen => 5,
LocalAddr => 'localhost',
Timeout => 10;
$listen or die "SLEEP: Cannot create listening socket: $!\n";
my $listenport = $listen->sockport;
my $pid = fork;
defined $pid or die "SLEEP: cannot fork: $!\n";
if ( $pid == 0 ) {
# child. connect from here to prevent deadlocks
my $connect = new IO::Socket::INET PeerAddr => "localhost:$listenport";
$connect or exit 0; # can't generate error.
my $dummy = <$connect>;
exit 0;
}
# parent. wait for an incoming connection, or possibly time out
my $accept = $listen->accept;
$accept or die "SLEEP: Error in accept: $!\n";
# phew. we have an incoming connection from ourselves. let's do the
# actual ident lookup.
my($os, $error);
($username, $os, $error) = Net::Ident::lookup($accept, 10);
defined $username or
die "SLEEP: Couldn't perform ident lookup: $error\n";
print "# identd tells us we're $username\n";
print $accept "you are $username\n";
close $accept;
close $listen;
# if you think the above is an extremely silly way to do getpwuid($<),
# think again. Just for fun, let's compare the ID we got with getpwuid
# and co... sometimes it IS different (for privacy-enhanced identd)
if ( (getpwuid($<) && $username ne getpwuid($<)) &&
(getlogin() && $username ne getlogin()) &&
($ENV{USER} && $username ne $ENV{USER}) )
{
print "# Hmm... that doesn't look like getpwuid(\$<) = \"",
getpwuid($<) || "(undef)", "\"\n";
print "# nor like getlogin() = \"", getlogin() || "(undef)", "\"\n";
print "# nor like $ENV{USER} = \"", $ENV{USER} || "(undef)", "\"\n";
}
# let apache warm up some more, if necessary
sleep $startuptime - time if $startuptime > time;
# test apache itself
my $result = GET($apache_addr, "/testapache.txt");
defined $result and $result =~ /^Apache OK/ or
die "Apache not ready\n";
print "# standard Apache OK\n";
GET($apache_addr, "/perl/testmodperl") =~ /^mod_perl OK/ or
die "mod_perl not ready\n";
print "# mod_perl OK\n";
};
if ( $@ ) {
my $reason = $@;
if ( $reason =~ /^SLEEP: (.*)$/s ) {
# we died too soon, apache is still starting up.
$reason = $1;
# make sure apache starts properly, else we can't kill it
sleep 5;
}
print "# $reason";
print "\n" unless $reason =~ /\n$/;
print "1..0\n";
exit 0;
}
# when we get here, identd is responding, apache is running, and mod_perl
# is functioning. Let's finally do some testing of Net::Ident
print "1..4\n";
my $i = 1;
my($reply, $header) = GET($apache_addr, "/perl/testident");
if ( ! defined $reply ) {
print "not ok $i\n"; $i++;
exit 0;
}
print "ok $i\n"; $i++;
if ( $header !~ m{\AHTTP/[\d.]+\s+(\d+)\s} || $1 ne "200" ) {
print "# apache barfed\n";
print "not ok $i\n"; $i++;
print STDERR "$header\n\n$reply\n";
exit 0;
}
print "ok $i\n"; $i++;
my ($func, $meth) = $reply =~ m{
^function\slookupFromInAddr\ssays\syou\sare:\s(.*)\n
ident_lookup\smethod\ssays\syou\sare:\s(.*)\n
}xm;
if ( ! defined $meth ) {
print "not ok $i\n"; $i++;
exit 0;
}
print "# ident lookup via apache returned: \"$func\" and \"$meth\"\n";
print( ($func eq $username) ? "ok $i\n" : "not ok $i\n"); $i++;
print( ($meth eq $username) ? "ok $i\n" : "not ok $i\n"); $i++;
|
