path: root/debian/perl-framework/Apache-Test/lib/Apache/TestServer.pm

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