# $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++;