diff options
Diffstat (limited to 'debian/perl-framework/Apache-Test/lib/Apache/TestServer.pm')
| -rw-r--r-- | debian/perl-framework/Apache-Test/lib/Apache/TestServer.pm | 724 |
1 files changed, 724 insertions, 0 deletions
diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestServer.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestServer.pm new file mode 100644 index 0000000..3a30a63 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestServer.pm @@ -0,0 +1,724 @@ +# 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; |