Adding debian version 2.4.56-1~deb11u2.debian/2.4.56-1_deb11u2debian

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

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;