lib/Apache/TestServer.pm - perl-apache-test - Git at Google

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