724 lines
19 KiB
Perl
724 lines
19 KiB
Perl
# Licensed to the Apache Software Foundation (ASF) under one or more
|
|
# contributor license agreements. See the NOTICE file distributed with
|
|
# this work for additional information regarding copyright ownership.
|
|
# The ASF licenses this file to You under the Apache License, Version 2.0
|
|
# (the "License"); you may not use this file except in compliance with
|
|
# the License. You may obtain a copy of the License at
|
|
#
|
|
# http://www.apache.org/licenses/LICENSE-2.0
|
|
#
|
|
# Unless required by applicable law or agreed to in writing, software
|
|
# distributed under the License is distributed on an "AS IS" BASIS,
|
|
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
# See the License for the specific language governing permissions and
|
|
# limitations under the License.
|
|
#
|
|
package Apache::TestServer;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
|
|
use Config;
|
|
use Socket ();
|
|
use File::Spec::Functions qw(catfile);
|
|
|
|
use Apache::TestTrace;
|
|
use Apache::TestRun;
|
|
use Apache::TestConfig ();
|
|
use Apache::TestRequest ();
|
|
|
|
use constant COLOR => Apache::TestConfig::COLOR;
|
|
use constant WIN32 => Apache::TestConfig::WIN32;
|
|
|
|
my $CTRL_M = COLOR ? "\r" : "\n";
|
|
|
|
# some debuggers use the same syntax as others, so we reuse the same
|
|
# code by using the following mapping
|
|
my %debuggers = (
|
|
gdb => 'gdb',
|
|
ddd => 'gdb',
|
|
valgrind => 'valgrind',
|
|
strace => 'strace',
|
|
);
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $config = shift;
|
|
|
|
my $self = bless {
|
|
config => $config || Apache::TestConfig->thaw,
|
|
}, $class;
|
|
|
|
$self->{name} = join ':',
|
|
map { $self->{config}->{vars}->{$_} } qw(servername port);
|
|
|
|
$self->{port_counter} = $self->{config}->{vars}->{port};
|
|
|
|
$self;
|
|
}
|
|
|
|
# call this when you already know where httpd is
|
|
sub post_config {
|
|
my($self) = @_;
|
|
|
|
$self->{version} = $self->{config}->httpd_version || '';
|
|
$self->{mpm} = $self->{config}->httpd_mpm || '';
|
|
|
|
# try to get the revision number from the standard Apache version
|
|
# string and various variations made by distributions which mangle
|
|
# that string
|
|
|
|
# Foo-Apache-Bar/x.y.z
|
|
($self->{rev}) = $self->{version} =~ m|/(\d)\.|;
|
|
|
|
if ($self->{rev}) {
|
|
debug "Matched Apache revision $self->{version} $self->{rev}";
|
|
}
|
|
else {
|
|
# guessing is not good as it'll only mislead users
|
|
# and we can't die since a config object is required
|
|
# during Makefile.PL's write_perlscript when path to httpd may
|
|
# be unknown yet. so default to non-existing version 0 for now.
|
|
# and let TestRun.pm figure out the required pieces
|
|
debug "can't figure out Apache revision, from string: " .
|
|
"'$self->{version}', using a non-existing revision 0";
|
|
$self->{rev} = 0; # unknown
|
|
}
|
|
|
|
($self->{revminor}) = $self->{version} =~ m|/\d\.(\d)|;
|
|
|
|
if ($self->{revminor}) {
|
|
debug "Matched Apache revminor $self->{version} $self->{revminor}";
|
|
}
|
|
else {
|
|
$self->{revminor} = 0;
|
|
}
|
|
|
|
$self;
|
|
}
|
|
|
|
sub version_of {
|
|
my($self, $thing) = @_;
|
|
die "Can't figure out what Apache server generation we are running"
|
|
unless $self->{rev};
|
|
|
|
$thing->{$self->{rev}};
|
|
}
|
|
|
|
my @apache_logs = qw(
|
|
error_log access_log httpd.pid
|
|
apache_runtime_status rewrite_log
|
|
ssl_engine_log ssl_request_log
|
|
cgisock
|
|
);
|
|
|
|
sub clean {
|
|
my $self = shift;
|
|
|
|
my $dir = $self->{config}->{vars}->{t_logs};
|
|
|
|
for (@apache_logs) {
|
|
my $file = catfile $dir, $_;
|
|
if (unlink $file) {
|
|
debug "unlink $file";
|
|
}
|
|
}
|
|
}
|
|
|
|
sub pid_file {
|
|
my $self = shift;
|
|
|
|
my $vars = $self->{config}->{vars};
|
|
|
|
return $vars->{t_pid_file} || catfile $vars->{t_logs}, 'httpd.pid';
|
|
}
|
|
|
|
sub dversion {
|
|
my $self = shift;
|
|
|
|
my $dv = "-D APACHE$self->{rev}";
|
|
|
|
if ($self->{rev} == 2 and $self->{revminor} == 4) {
|
|
$dv .= " -D APACHE2_4";
|
|
}
|
|
|
|
return $dv;
|
|
}
|
|
|
|
sub config_defines {
|
|
my $self = shift;
|
|
|
|
my @defines = ();
|
|
|
|
for my $item (qw(useithreads)) {
|
|
next unless $Config{$item} and $Config{$item} eq 'define';
|
|
push @defines, "-D PERL_\U$item";
|
|
}
|
|
|
|
if (my $defines = $self->{config}->{vars}->{defines}) {
|
|
push @defines, map { "-D $_" } split " ", $defines;
|
|
}
|
|
|
|
"@defines";
|
|
}
|
|
|
|
sub args {
|
|
my $self = shift;
|
|
my $vars = $self->{config}->{vars};
|
|
my $dversion = $self->dversion; #for .conf version conditionals
|
|
my $defines = $self->config_defines;
|
|
|
|
"-d $vars->{serverroot} -f $vars->{t_conf_file} $dversion $defines";
|
|
}
|
|
|
|
my %one_process = (1 => '-X', 2 => '-D ONE_PROCESS');
|
|
|
|
sub start_cmd {
|
|
my $self = shift;
|
|
|
|
my $args = $self->args;
|
|
my $config = $self->{config};
|
|
my $vars = $config->{vars};
|
|
my $httpd = $vars->{httpd};
|
|
|
|
my $one_process = $self->{run}->{opts}->{'one-process'}
|
|
? $self->version_of(\%one_process)
|
|
: '';
|
|
|
|
#XXX: threaded mpm does not respond to SIGTERM with -D ONE_PROCESS
|
|
|
|
return "$httpd $one_process $args";
|
|
}
|
|
|
|
sub default_gdbinit {
|
|
my $gdbinit = "";
|
|
my @sigs = qw(PIPE);
|
|
|
|
for my $sig (@sigs) {
|
|
for my $flag (qw(pass nostop)) {
|
|
$gdbinit .= "handle SIG$sig $flag\n";
|
|
}
|
|
}
|
|
|
|
$gdbinit;
|
|
}
|
|
|
|
sub strace_cmd {
|
|
my($self, $strace, $file) = @_;
|
|
#XXX truss, ktrace, etc.
|
|
"$strace -f -o $file -s1024";
|
|
}
|
|
|
|
sub valgrind_cmd {
|
|
my($self, $valgrind) = @_;
|
|
"$valgrind -v --leak-check=yes --show-reachable=yes --error-limit=no";
|
|
}
|
|
|
|
sub start_valgrind {
|
|
my $self = shift;
|
|
my $opts = shift;
|
|
|
|
my $config = $self->{config};
|
|
my $args = $self->args;
|
|
my $one_process = $self->version_of(\%one_process);
|
|
my $valgrind_cmd = $self->valgrind_cmd($opts->{debugger});
|
|
my $httpd = $config->{vars}->{httpd};
|
|
|
|
my $command = "$valgrind_cmd $httpd $one_process $args";
|
|
|
|
debug $command;
|
|
system $command;
|
|
}
|
|
|
|
sub start_strace {
|
|
my $self = shift;
|
|
my $opts = shift;
|
|
|
|
my $config = $self->{config};
|
|
my $args = $self->args;
|
|
my $one_process = $self->version_of(\%one_process);
|
|
my $file = catfile $config->{vars}->{t_logs}, 'strace.log';
|
|
my $strace_cmd = $self->strace_cmd($opts->{debugger}, $file);
|
|
my $httpd = $config->{vars}->{httpd};
|
|
|
|
$config->genfile($file); #just mark for cleanup
|
|
|
|
my $command = "$strace_cmd $httpd $one_process $args";
|
|
|
|
debug $command;
|
|
system $command;
|
|
}
|
|
|
|
sub start_gdb {
|
|
my $self = shift;
|
|
my $opts = shift;
|
|
|
|
my $debugger = $opts->{debugger};
|
|
my @breakpoints = @{ $opts->{breakpoint} || [] };
|
|
my $config = $self->{config};
|
|
my $args = $self->args;
|
|
my $one_process = $self->version_of(\%one_process);
|
|
|
|
my $file = catfile $config->{vars}->{serverroot}, '.gdb-test-start';
|
|
my $fh = $config->genfile($file);
|
|
|
|
print $fh default_gdbinit();
|
|
|
|
if (@breakpoints) {
|
|
print $fh "b ap_run_pre_config\n";
|
|
print $fh "run $one_process $args\n";
|
|
print $fh "finish\n";
|
|
for (@breakpoints) {
|
|
print $fh "b $_\n"
|
|
}
|
|
print $fh "continue\n";
|
|
}
|
|
else {
|
|
print $fh "run $one_process $args\n";
|
|
}
|
|
close $fh;
|
|
|
|
my $command;
|
|
my $httpd = $config->{vars}->{httpd};
|
|
|
|
if ($debugger eq 'ddd') {
|
|
$command = qq{ddd --gdb --debugger "gdb -command $file" $httpd};
|
|
}
|
|
else {
|
|
## defaults to gdb if not set in %ENV or via -debug
|
|
$command = "$debugger $httpd -command $file";
|
|
}
|
|
|
|
$self->note_debugging;
|
|
debug $command;
|
|
system $command;
|
|
|
|
unlink $file;
|
|
}
|
|
|
|
sub debugger_file {
|
|
my $self = shift;
|
|
catfile $self->{config}->{vars}->{serverroot}, '.debugging';
|
|
}
|
|
|
|
#make a note that the server is running under the debugger
|
|
#remove note when this process exits via END
|
|
|
|
sub note_debugging {
|
|
my $self = shift;
|
|
my $file = $self->debugger_file;
|
|
my $fh = $self->{config}->genfile($file);
|
|
eval qq(END { unlink "$file" });
|
|
}
|
|
|
|
sub start_debugger {
|
|
my $self = shift;
|
|
my $opts = shift;
|
|
|
|
$opts->{debugger} ||= $ENV{MP_DEBUGGER} || 'gdb';
|
|
|
|
# XXX: FreeBSD 5.2+
|
|
# gdb 6.1 and before segfaults when trying to
|
|
# debug httpd startup code. 6.5 has been proven
|
|
# to work. FreeBSD typically installs this as
|
|
# gdb65.
|
|
# Is it worth it to check the debugger and os version
|
|
# and die ?
|
|
|
|
unless (grep { /^$opts->{debugger}/ } keys %debuggers) {
|
|
error "$opts->{debugger} is not a supported debugger",
|
|
"These are the supported debuggers: ".
|
|
join ", ", sort keys %debuggers;
|
|
die("\n");
|
|
}
|
|
|
|
my $debugger = $opts->{debugger};
|
|
$debugger =~ s/\d+$//;
|
|
|
|
my $method = "start_" . $debuggers{$debugger};
|
|
|
|
## $opts->{debugger} is passed through unchanged
|
|
## so when we try to run it next, its found.
|
|
$self->$method($opts);
|
|
}
|
|
|
|
sub pid {
|
|
my $self = shift;
|
|
my $file = $self->pid_file;
|
|
my $fh = Symbol::gensym();
|
|
open $fh, $file or do {
|
|
return 0;
|
|
};
|
|
|
|
# try to avoid the race condition when the pid file was created
|
|
# but not yet written to
|
|
for (1..8) {
|
|
last if -s $file > 0;
|
|
select undef, undef, undef, 0.25;
|
|
}
|
|
|
|
chomp(my $pid = <$fh> || '');
|
|
$pid;
|
|
}
|
|
|
|
sub select_next_port {
|
|
my $self = shift;
|
|
|
|
my $max_tries = 100; #XXX
|
|
while ($max_tries-- > 0) {
|
|
return $self->{port_counter}
|
|
if $self->port_available(++$self->{port_counter});
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub port_available {
|
|
my $self = shift;
|
|
my $port = shift || $self->{config}->{vars}->{port};
|
|
local *S;
|
|
|
|
my $proto = getprotobyname('tcp');
|
|
|
|
socket(S, Socket::PF_INET(),
|
|
Socket::SOCK_STREAM(), $proto) || die "socket: $!";
|
|
setsockopt(S, Socket::SOL_SOCKET(),
|
|
Socket::SO_REUSEADDR(),
|
|
pack("l", 1)) || die "setsockopt: $!";
|
|
|
|
if (bind(S, Socket::sockaddr_in($port, Socket::INADDR_ANY()))) {
|
|
close S;
|
|
return 1;
|
|
}
|
|
else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
=head2 stop()
|
|
|
|
attempt to stop the server.
|
|
|
|
returns:
|
|
|
|
on success: $pid of the server
|
|
on failure: -1
|
|
|
|
=cut
|
|
|
|
sub stop {
|
|
my $self = shift;
|
|
my $aborted = shift;
|
|
|
|
if (WIN32) {
|
|
require Win32::Process;
|
|
my $obj = $self->{config}->{win32obj};
|
|
my $pid = -1;
|
|
if ($pid = $obj ? $obj->GetProcessID : $self->pid) {
|
|
if (kill(0, $pid)) {
|
|
Win32::Process::KillProcess($pid, 0);
|
|
warning "server $self->{name} shutdown";
|
|
}
|
|
}
|
|
unlink $self->pid_file if -e $self->pid_file;
|
|
return $pid;
|
|
}
|
|
|
|
my $pid = 0;
|
|
my $tries = 3;
|
|
my $tried_kill = 0;
|
|
|
|
my $port = $self->{config}->{vars}->{port};
|
|
|
|
while ($self->ping) {
|
|
#my $state = $tried_kill ? "still" : "already";
|
|
#print "Port $port $state in use\n";
|
|
|
|
if ($pid = $self->pid and !$tried_kill++) {
|
|
if (kill TERM => $pid) {
|
|
warning "server $self->{name} shutdown";
|
|
sleep 1;
|
|
|
|
for (1..6) {
|
|
if (! $self->ping) {
|
|
if ($_ == 1) {
|
|
unlink $self->pid_file if -e $self->pid_file;
|
|
return $pid;
|
|
}
|
|
last;
|
|
}
|
|
if ($_ == 1) {
|
|
warning "port $port still in use...";
|
|
}
|
|
else {
|
|
print "...";
|
|
}
|
|
sleep $_;
|
|
}
|
|
|
|
if ($self->ping) {
|
|
error "\nserver was shutdown but port $port ".
|
|
"is still in use, please shutdown the service ".
|
|
"using this port or select another port ".
|
|
"for the tests";
|
|
}
|
|
else {
|
|
print "done\n";
|
|
}
|
|
}
|
|
else {
|
|
error "kill $pid failed: $!";
|
|
}
|
|
}
|
|
else {
|
|
error "port $port is in use, ".
|
|
"cannot determine server pid to shutdown";
|
|
return -1;
|
|
}
|
|
|
|
if (--$tries <= 0) {
|
|
error "cannot shutdown server on Port $port, ".
|
|
"please shutdown manually";
|
|
unlink $self->pid_file if -e $self->pid_file;
|
|
return -1;
|
|
}
|
|
}
|
|
|
|
unlink $self->pid_file if -e $self->pid_file;
|
|
return $pid;
|
|
}
|
|
|
|
sub ping {
|
|
my $self = shift;
|
|
my $pid = $self->pid;
|
|
|
|
if ($pid and kill 0, $pid) {
|
|
return $pid;
|
|
}
|
|
elsif (! $self->port_available) {
|
|
return -1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub failed_msg {
|
|
my $self = shift;
|
|
my($log, $rlog) = $self->{config}->error_log;
|
|
my $log_file_info = -e $log ?
|
|
"please examine $rlog" :
|
|
"$rlog wasn't created, start the server in the debug mode";
|
|
error "@_ ($log_file_info)";
|
|
}
|
|
|
|
#this doesn't work well on solaris or hpux at the moment
|
|
use constant USE_SIGCHLD => $^O eq 'linux';
|
|
|
|
sub start {
|
|
my $self = shift;
|
|
|
|
my $old_pid = -1;
|
|
if (WIN32) {
|
|
# Stale PID files (e.g. left behind from a previous test run
|
|
# that crashed) cannot be trusted on Windows because PID's are
|
|
# re-used too frequently, so just remove it. If there is an old
|
|
# server still running then the attempt to start a new one below
|
|
# will simply fail because the port will be unavailable.
|
|
if (-f $self->pid_file) {
|
|
error "Removing old PID file -- " .
|
|
"Unclean shutdown of previous test run?\n";
|
|
unlink $self->pid_file;
|
|
}
|
|
$old_pid = 0;
|
|
}
|
|
else {
|
|
$old_pid = $self->stop;
|
|
}
|
|
my $cmd = $self->start_cmd;
|
|
my $config = $self->{config};
|
|
my $vars = $config->{vars};
|
|
my $httpd = $vars->{httpd} || 'unknown';
|
|
|
|
if ($old_pid == -1) {
|
|
return 0;
|
|
}
|
|
|
|
local $| = 1;
|
|
|
|
unless (-x $httpd) {
|
|
my $why = -e $httpd ? "is not executable" : "does not exist";
|
|
error "cannot start server: httpd ($httpd) $why";
|
|
return 0;
|
|
}
|
|
|
|
print "$cmd\n";
|
|
my $old_sig;
|
|
|
|
if (WIN32) {
|
|
#make sure only 1 process is started for win32
|
|
#else Kill will only shutdown the parent
|
|
my $one_process = $self->version_of(\%one_process);
|
|
require Win32::Process;
|
|
my $obj;
|
|
# We need the "1" below to inherit the calling processes
|
|
# handles when running Apache::TestSmoke so as to properly
|
|
# dup STDOUT/STDERR
|
|
Win32::Process::Create($obj,
|
|
$httpd,
|
|
"$cmd $one_process",
|
|
1,
|
|
Win32::Process::NORMAL_PRIORITY_CLASS(),
|
|
'.');
|
|
unless ($obj) {
|
|
die "Could not start the server: " .
|
|
Win32::FormatMessage(Win32::GetLastError());
|
|
}
|
|
$config->{win32obj} = $obj;
|
|
}
|
|
else {
|
|
$old_sig = $SIG{CHLD};
|
|
|
|
if (USE_SIGCHLD) {
|
|
# XXX: try not to be POSIX dependent
|
|
require POSIX;
|
|
|
|
#XXX: this is not working well on solaris or hpux
|
|
$SIG{CHLD} = sub {
|
|
while ((my $child = waitpid(-1, POSIX::WNOHANG())) > 0) {
|
|
my $status = $? >> 8;
|
|
#error "got child exit $status";
|
|
if ($status) {
|
|
my $msg = "server has died with status $status";
|
|
$self->failed_msg("\n$msg");
|
|
Apache::TestRun->new(test_config => $config)->scan_core;
|
|
kill SIGTERM => $$;
|
|
}
|
|
}
|
|
};
|
|
}
|
|
|
|
defined(my $pid = fork) or die "Can't fork: $!";
|
|
unless ($pid) { # child
|
|
my $status = system "$cmd";
|
|
if ($status) {
|
|
$status = $? >> 8;
|
|
#error "httpd didn't start! $status";
|
|
}
|
|
CORE::exit $status;
|
|
}
|
|
}
|
|
|
|
while ($old_pid and $old_pid == $self->pid) {
|
|
warning "old pid file ($old_pid) still exists";
|
|
sleep 1;
|
|
}
|
|
|
|
my $version = $self->{version};
|
|
my $mpm = $config->{mpm} || "";
|
|
$mpm = "($mpm MPM)" if $mpm;
|
|
print "using $version $mpm\n";
|
|
|
|
my $timeout = $vars->{startup_timeout} ||
|
|
$ENV{APACHE_TEST_STARTUP_TIMEOUT} ||
|
|
60;
|
|
|
|
my $start_time = time;
|
|
my $preamble = "${CTRL_M}waiting $timeout seconds for server to start: ";
|
|
print $preamble unless COLOR;
|
|
while (1) {
|
|
my $delta = time - $start_time;
|
|
print COLOR
|
|
? ($preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0])
|
|
: '.';
|
|
sleep 1;
|
|
if ($self->pid) {
|
|
print $preamble, "ok (waited $delta secs)\n";
|
|
last;
|
|
}
|
|
elsif ($delta > $timeout) {
|
|
my $suggestion = $timeout + 300;
|
|
print $preamble, "not ok\n";
|
|
error <<EOI;
|
|
giving up after $delta secs. If you think that your system
|
|
is slow or overloaded try again with a longer timeout value.
|
|
by setting the environment variable APACHE_TEST_STARTUP_TIMEOUT
|
|
to a high value (e.g. $suggestion) and repeat the last command.
|
|
EOI
|
|
last;
|
|
}
|
|
}
|
|
|
|
# now that the server has started don't abort the test run if it
|
|
# dies
|
|
$SIG{CHLD} = $old_sig || 'DEFAULT';
|
|
|
|
if (my $pid = $self->pid) {
|
|
print "server $self->{name} started\n";
|
|
|
|
my $vh = $config->{vhosts};
|
|
my $by_port = sub { $vh->{$a}->{port} <=> $vh->{$b}->{port} };
|
|
|
|
for my $module (sort $by_port keys %$vh) {
|
|
print "server $vh->{$module}->{name} listening ($module)\n",
|
|
}
|
|
|
|
if ($config->configure_proxy) {
|
|
print "tests will be proxied through $vars->{proxy}\n";
|
|
}
|
|
}
|
|
else {
|
|
$self->failed_msg("server failed to start!");
|
|
return 0;
|
|
}
|
|
|
|
return 1 if $self->wait_till_is_up($timeout);
|
|
|
|
$self->failed_msg("failed to start server!");
|
|
return 0;
|
|
}
|
|
|
|
|
|
# wait till the server is up and return 1
|
|
# if the waiting times out returns 0
|
|
sub wait_till_is_up {
|
|
my($self, $timeout) = @_;
|
|
my $config = $self->{config};
|
|
my $sleep_interval = 1; # secs
|
|
|
|
my $server_up = sub {
|
|
local $SIG{__WARN__} = sub {}; #avoid "cannot connect ..." warnings
|
|
# avoid fatal errors when LWP is not available
|
|
return eval {
|
|
my $r=Apache::TestRequest::GET('/index.html');
|
|
$r->code!=500 or $r->header('client-warning')!~/internal/i;
|
|
} || 0;
|
|
};
|
|
|
|
if ($server_up->()) {
|
|
return 1;
|
|
}
|
|
|
|
my $start_time = time;
|
|
my $preamble = "${CTRL_M}still waiting for server to warm up: ";
|
|
print $preamble unless COLOR;
|
|
while (1) {
|
|
my $delta = time - $start_time;
|
|
print COLOR
|
|
? ($preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0])
|
|
: '.';
|
|
sleep $sleep_interval;
|
|
if ($server_up->()) {
|
|
print "${CTRL_M}the server is up (waited $delta secs) \n";
|
|
return 1;
|
|
}
|
|
elsif ($delta > $timeout) {
|
|
print "${CTRL_M}the server is down, giving up after $delta secs\n";
|
|
return 0;
|
|
}
|
|
else {
|
|
# continue
|
|
}
|
|
}
|
|
}
|
|
|
|
1;
|