home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / TestServer.pm < prev    next >
Encoding:
Perl POD Document  |  2004-08-06  |  17.9 KB  |  683 lines
  1. # Copyright 2001-2004 The Apache Software Foundation
  2. #
  3. # Licensed under the Apache License, Version 2.0 (the "License");
  4. # you may not use this file except in compliance with the License.
  5. # You may obtain a copy of the License at
  6. #
  7. #     http://www.apache.org/licenses/LICENSE-2.0
  8. #
  9. # Unless required by applicable law or agreed to in writing, software
  10. # distributed under the License is distributed on an "AS IS" BASIS,
  11. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  12. # See the License for the specific language governing permissions and
  13. # limitations under the License.
  14. #
  15. package Apache::TestServer;
  16.  
  17. use strict;
  18. use warnings FATAL => 'all';
  19.  
  20. use Config;
  21. use Socket ();
  22. use File::Spec::Functions qw(catfile);
  23.  
  24. use Apache::TestTrace;
  25. use Apache::TestRun;
  26. use Apache::TestConfig ();
  27. use Apache::TestRequest ();
  28.  
  29. use constant COLOR => Apache::TestConfig::COLOR;
  30. use constant WIN32 => Apache::TestConfig::WIN32;
  31.  
  32. my $CTRL_M = COLOR ? "\r" : "\n";
  33.  
  34. # some debuggers use the same syntax as others, so we reuse the same
  35. # code by using the following mapping
  36. my %debuggers = (
  37.     gdb      => 'gdb',
  38.     ddd      => 'gdb',
  39.     valgrind => 'valgrind',
  40.     strace   => 'strace',
  41. );
  42.  
  43. sub new {
  44.     my $class = shift;
  45.     my $config = shift;
  46.  
  47.     my $self = bless {
  48.         config => $config || Apache::TestConfig->thaw,
  49.     }, $class;
  50.  
  51.     $self->{name} = join ':',
  52.       map { $self->{config}->{vars}->{$_} } qw(servername port);
  53.  
  54.     $self->{port_counter} = $self->{config}->{vars}->{port};
  55.  
  56.     $self;
  57. }
  58.  
  59. # call this when you already know where httpd is
  60. sub post_config {
  61.     my($self) = @_;
  62.  
  63.     $self->{version} = $self->{config}->httpd_version || '';
  64.     $self->{mpm}     = $self->{config}->httpd_mpm     || '';
  65.  
  66.     # try to get the revision number from the standard Apache version
  67.     # string and various variations made by distributions which mangle
  68.     # that string
  69.  
  70.     # Apache/2.0.50-dev
  71.     ($self->{rev})   = $self->{version} =~ m|^Apache/(\d)\.|;
  72.  
  73.     # Apache-AdvancedExtranetServer/1.3.29 (Mandrake Linux/1mdk)
  74.     ($self->{rev}) ||= $self->{version} =~ m|^Apache.*?/(\d)\.|;
  75.  
  76.     # IBM_HTTP_SERVER/1.3.19  Apache/1.3.20 (Unix)
  77.     ($self->{rev}) ||= $self->{version} =~ m|^.*?Apache.*?/(\d)\.|;
  78.  
  79.     if ($self->{rev}) {
  80.         debug "Matched Apache revision $self->{version} $self->{rev}";
  81.     }
  82.     else {
  83.         # guessing is not good as it'll only mislead users
  84.         # and we can't die since a config object is required
  85.         # during Makefile.PL's write_perlscript when path to httpd may
  86.         # be unknown yet. so default to non-existing version 0 for now.
  87.         # and let TestRun.pm figure out the required pieces
  88.         debug "can't figure out Apache revision, from string: " .
  89.             "'$self->{version}', using a non-existing revision 0";
  90.         $self->{rev} = 0; # unknown
  91.     }
  92.  
  93.     $self;
  94. }
  95.  
  96. sub version_of {
  97.     my($self, $thing) = @_;
  98.     die "Can't figure out what Apache server generation we are running"
  99.         unless $self->{rev};
  100.  
  101.     $thing->{$self->{rev}};
  102. }
  103.  
  104. my @apache_logs = qw(
  105. error_log access_log httpd.pid
  106. apache_runtime_status rewrite_log
  107. ssl_engine_log ssl_request_log
  108. );
  109.  
  110. sub clean {
  111.     my $self = shift;
  112.  
  113.     my $dir = $self->{config}->{vars}->{t_logs};
  114.  
  115.     for (@apache_logs) {
  116.         my $file = catfile $dir, $_;
  117.         if (unlink $file) {
  118.             debug "unlink $file";
  119.         }
  120.     }
  121. }
  122.  
  123. sub pid_file {
  124.     my $self = shift;
  125.     catfile $self->{config}->{vars}->{t_logs}, 'httpd.pid';
  126. }
  127.  
  128. sub dversion {
  129.     my $self = shift;
  130.     "-D APACHE$self->{rev}";
  131. }
  132.  
  133. sub config_defines {
  134.     my $self = shift;
  135.  
  136.     my @defines = ();
  137.  
  138.     for my $item (qw(useithreads)) {
  139.         next unless $Config{$item} and $Config{$item} eq 'define';
  140.         push @defines, "-D PERL_\U$item";
  141.     }
  142.  
  143.     if (my $defines = $self->{config}->{vars}->{defines}) {
  144.         push @defines, map { "-D $_" } split " ", $defines;
  145.     }
  146.  
  147.     "@defines";
  148. }
  149.  
  150. sub args {
  151.     my $self = shift;
  152.     my $vars = $self->{config}->{vars};
  153.     my $dversion = $self->dversion; #for .conf version conditionals
  154.     my $defines = $self->config_defines;
  155.  
  156.     "-d $vars->{serverroot} -f $vars->{t_conf_file} $dversion $defines";
  157. }
  158.  
  159. my %one_process = (1 => '-X', 2 => '-D ONE_PROCESS');
  160.  
  161. sub start_cmd {
  162.     my $self = shift;
  163.     #XXX: threaded mpm does not respond to SIGTERM with -D ONE_PROCESS
  164.     my $args = $self->args;
  165.     return "$self->{config}->{vars}->{httpd} $args";
  166. }
  167.  
  168. sub default_gdbinit {
  169.     my $gdbinit = "";
  170.     my @sigs = qw(PIPE);
  171.  
  172.     for my $sig (@sigs) {
  173.         for my $flag (qw(pass nostop)) {
  174.             $gdbinit .= "handle SIG$sig $flag\n";
  175.         }
  176.     }
  177.  
  178.     $gdbinit;
  179. }
  180.  
  181. sub strace_cmd {
  182.     my($self, $strace, $file) = @_;
  183.     #XXX truss, ktrace, etc.
  184.     "$strace -f -o $file -s1024";
  185. }
  186.  
  187. sub valgrind_cmd {
  188.     my($self, $valgrind) = @_;
  189.     "$valgrind -v --leak-check=yes --show-reachable=yes --error-limit=no";
  190. }
  191.  
  192. sub start_valgrind {
  193.     my $self = shift;
  194.     my $opts = shift;
  195.  
  196.     my $config       = $self->{config};
  197.     my $args         = $self->args;
  198.     my $one_process  = $self->version_of(\%one_process);
  199.     my $valgrind_cmd = $self->valgrind_cmd($opts->{debugger});
  200.     my $httpd        = $config->{vars}->{httpd};
  201.  
  202.     my $command = "$valgrind_cmd $httpd $one_process $args";
  203.  
  204.     debug $command;
  205.     system $command;
  206. }
  207.  
  208. sub start_strace {
  209.     my $self = shift;
  210.     my $opts = shift;
  211.  
  212.     my $config      = $self->{config};
  213.     my $args        = $self->args;
  214.     my $one_process = $self->version_of(\%one_process);
  215.     my $file        = catfile $config->{vars}->{t_logs}, 'strace.log';
  216.     my $strace_cmd  = $self->strace_cmd($opts->{debugger}, $file);
  217.     my $httpd       = $config->{vars}->{httpd};
  218.  
  219.     $config->genfile($file); #just mark for cleanup
  220.  
  221.     my $command = "$strace_cmd $httpd $one_process $args";
  222.  
  223.     debug $command;
  224.     system $command;
  225. }
  226.  
  227. sub start_gdb {
  228.     my $self = shift;
  229.     my $opts = shift;
  230.  
  231.     my $debugger    = $opts->{debugger};
  232.     my @breakpoints = @{ $opts->{breakpoint} || [] };
  233.     my $config      = $self->{config};
  234.     my $args        = $self->args;
  235.     my $one_process = $self->version_of(\%one_process);
  236.  
  237.     my $file = catfile $config->{vars}->{serverroot}, '.gdb-test-start';
  238.     my $fh   = $config->genfile($file);
  239.  
  240.     print $fh default_gdbinit();
  241.  
  242.     if (@breakpoints) {
  243.         print $fh "b ap_run_pre_config\n";
  244.         print $fh "run $one_process $args\n";
  245.         print $fh "finish\n";
  246.         for (@breakpoints) {
  247.             print $fh "b $_\n"
  248.         }
  249.         print $fh "continue\n";
  250.     }
  251.     else {
  252.         print $fh "run $one_process $args\n";
  253.     }
  254.     close $fh;
  255.  
  256.     my $command;
  257.     my $httpd = $config->{vars}->{httpd};
  258.  
  259.     if ($debugger eq 'ddd') {
  260.         $command = qq{ddd --gdb --debugger "gdb -command $file" $httpd};
  261.     }
  262.     else {
  263.         $command = "gdb $httpd -command $file";
  264.     }
  265.  
  266.     $self->note_debugging;
  267.     debug  $command;
  268.     system $command;
  269.  
  270.     unlink $file;
  271. }
  272.  
  273. sub debugger_file {
  274.     my $self = shift;
  275.     catfile $self->{config}->{vars}->{serverroot}, '.debugging';
  276. }
  277.  
  278. #make a note that the server is running under the debugger
  279. #remove note when this process exits via END
  280.  
  281. sub note_debugging {
  282.     my $self = shift;
  283.     my $file = $self->debugger_file;
  284.     my $fh   = $self->{config}->genfile($file);
  285.     eval qq(END { unlink "$file" });
  286. }
  287.  
  288. sub start_debugger {
  289.     my $self = shift;
  290.     my $opts = shift;
  291.  
  292.     $opts->{debugger} ||= $ENV{MP_DEBUGGER} || 'gdb';
  293.  
  294.     unless ($debuggers{ $opts->{debugger} }) {
  295.         error "$opts->{debugger} is not a supported debugger",
  296.               "These are the supported debuggers: ".
  297.               join ", ", sort keys %debuggers;
  298.         die("\n");
  299.     }
  300.  
  301.     my $method = "start_" . $debuggers{ $opts->{debugger} };
  302.     $self->$method($opts);
  303. }
  304.  
  305. sub pid {
  306.     my $self = shift;
  307.     my $file = $self->pid_file;
  308.     my $fh = Symbol::gensym();
  309.     open $fh, $file or do {
  310.         return 0;
  311.     };
  312.  
  313.     # try to avoid the race condition when the pid file was created
  314.     # but not yet written to
  315.     for (1..8) {
  316.         last if -s $file > 0;
  317.         select undef, undef, undef, 0.25;
  318.     }
  319.  
  320.     chomp(my $pid = <$fh> || '');
  321.     $pid;
  322. }
  323.  
  324. sub select_next_port {
  325.     my $self = shift;
  326.  
  327.     my $max_tries = 100; #XXX
  328.     while ($max_tries-- > 0) {
  329.         return $self->{port_counter}
  330.             if $self->port_available(++$self->{port_counter});
  331.     }
  332.  
  333.     return 0;
  334. }
  335.  
  336. sub port_available {
  337.     my $self = shift;
  338.     my $port = shift || $self->{config}->{vars}->{port};
  339.     local *S;
  340.  
  341.     my $proto = getprotobyname('tcp');
  342.  
  343.     socket(S, Socket::PF_INET(),
  344.            Socket::SOCK_STREAM(), $proto) || die "socket: $!";
  345.     setsockopt(S, Socket::SOL_SOCKET(),
  346.                Socket::SO_REUSEADDR(),
  347.                pack("l", 1)) || die "setsockopt: $!";
  348.  
  349.     if (bind(S, Socket::sockaddr_in($port, Socket::INADDR_ANY()))) {
  350.         close S;
  351.         return 1;
  352.     }
  353.     else {
  354.         return 0;
  355.     }
  356. }
  357.  
  358. =head2 stop()
  359.  
  360. attempt to stop the server.
  361.  
  362. returns:
  363.  
  364.   on success: $pid of the server
  365.   on failure: -1
  366.  
  367. =cut
  368.  
  369. sub stop {
  370.     my $self = shift;
  371.     my $aborted = shift;
  372.  
  373.     if (WIN32) {
  374.         require Win32::Process;
  375.         my $obj = $self->{config}->{win32obj};
  376.         my $pid = -1;
  377.         if ($pid = $obj ? $obj->GetProcessID : $self->pid) {
  378.             if (kill(0, $pid)) {
  379.                 Win32::Process::KillProcess($pid, 0);
  380.                 warning "server $self->{name} shutdown";
  381.             }
  382.         }
  383.         unlink $self->pid_file if -e $self->pid_file;
  384.         return $pid;
  385.     }
  386.  
  387.     my $pid = 0;
  388.     my $tries = 3;
  389.     my $tried_kill = 0;
  390.  
  391.     my $port = $self->{config}->{vars}->{port};
  392.  
  393.     while ($self->ping) {
  394.         #my $state = $tried_kill ? "still" : "already";
  395.         #print "Port $port $state in use\n";
  396.  
  397.         if ($pid = $self->pid and !$tried_kill++) {
  398.             if (kill TERM => $pid) {
  399.                 warning "server $self->{name} shutdown";
  400.                 sleep 1;
  401.  
  402.                 for (1..6) {
  403.                     if (! $self->ping) {
  404.                         if ($_ == 1) {
  405.                             unlink $self->pid_file if -e $self->pid_file;
  406.                             return $pid;
  407.                         }
  408.                         last;
  409.                     }
  410.                     if ($_ == 1) {
  411.                         warning "port $port still in use...";
  412.                     }
  413.                     else {
  414.                         print "...";
  415.                     }
  416.                     sleep $_;
  417.                 }
  418.  
  419.                 if ($self->ping) {
  420.                     error "\nserver was shutdown but port $port ".
  421.                           "is still in use, please shutdown the service ".
  422.                           "using this port or select another port ".
  423.                           "for the tests";
  424.                 }
  425.                 else {
  426.                     print "done\n";
  427.                 }
  428.             }
  429.             else {
  430.                 error "kill $pid failed: $!";
  431.             }
  432.         }
  433.         else {
  434.             error "port $port is in use, ".
  435.                   "cannot determine server pid to shutdown";
  436.             return -1;
  437.         }
  438.  
  439.         if (--$tries <= 0) {
  440.             error "cannot shutdown server on Port $port, ".
  441.                   "please shutdown manually";
  442.             unlink $self->pid_file if -e $self->pid_file;
  443.             return -1;
  444.         }
  445.     }
  446.  
  447.     unlink $self->pid_file if -e $self->pid_file;
  448.     return $pid;
  449. }
  450.  
  451. sub ping {
  452.     my $self = shift;
  453.     my $pid = $self->pid;
  454.  
  455.     if ($pid and kill 0, $pid) {
  456.         return $pid;
  457.     }
  458.     elsif (! $self->port_available) {
  459.         return -1;
  460.     }
  461.  
  462.     return 0;
  463. }
  464.  
  465. sub failed_msg {
  466.     my $self = shift;
  467.     my($log, $rlog) = $self->{config}->error_log;
  468.     my $log_file_info = -e $log ?
  469.         "please examine $rlog" :
  470.         "$rlog wasn't created, start the server in the debug mode";
  471.     error "@_ ($log_file_info)";
  472. }
  473.  
  474. #this doesn't work well on solaris or hpux at the moment
  475. use constant USE_SIGCHLD => $^O eq 'linux';
  476.  
  477. sub start {
  478.     my $self = shift;
  479.  
  480.     my $old_pid = -1;
  481.     if (WIN32) {
  482.         # Stale PID files (e.g. left behind from a previous test run
  483.         # that crashed) cannot be trusted on Windows because PID's are
  484.         # re-used too frequently, so just remove it. If there is an old
  485.         # server still running then the attempt to start a new one below
  486.         # will simply fail because the port will be unavailable.
  487.         if (-f $self->pid_file) {
  488.             error "Removing old PID file -- " .
  489.                 "Unclean shutdown of previous test run?\n";
  490.             unlink $self->pid_file;
  491.         }
  492.         $old_pid = 0;
  493.     }
  494.     else {
  495.         $old_pid = $self->stop;
  496.     }
  497.     my $cmd = $self->start_cmd;
  498.     my $config = $self->{config};
  499.     my $vars = $config->{vars};
  500.     my $httpd = $vars->{httpd} || 'unknown';
  501.  
  502.     if ($old_pid == -1) {
  503.         return 0;
  504.     }
  505.  
  506.     local $| = 1;
  507.  
  508.     unless (-x $httpd) {
  509.         my $why = -e $httpd ? "is not executable" : "does not exist";
  510.         error "cannot start server: httpd ($httpd) $why";
  511.         return 0;
  512.     }
  513.  
  514.     print "$cmd\n";
  515.     my $old_sig;
  516.  
  517.     if (WIN32) {
  518.         #make sure only 1 process is started for win32
  519.         #else Kill will only shutdown the parent
  520.         my $one_process = $self->version_of(\%one_process);
  521.         require Win32::Process;
  522.         my $obj;
  523.         # We need the "1" below to inherit the calling processes
  524.         # handles when running Apache::TestSmoke so as to properly
  525.         # dup STDOUT/STDERR
  526.         Win32::Process::Create($obj,
  527.                                $httpd,
  528.                                "$cmd $one_process",
  529.                                1,
  530.                                Win32::Process::NORMAL_PRIORITY_CLASS(),
  531.                                '.');
  532.         unless ($obj) {
  533.             die "Could not start the server: " .
  534.                 Win32::FormatMessage(Win32::GetLastError());
  535.         }
  536.         $config->{win32obj} = $obj;
  537.     }
  538.     else {
  539.         $old_sig = $SIG{CHLD};
  540.  
  541.         if (USE_SIGCHLD) {
  542.             # XXX: try not to be POSIX dependent
  543.             require POSIX;
  544.  
  545.             #XXX: this is not working well on solaris or hpux
  546.             $SIG{CHLD} = sub {
  547.                 while ((my $child = waitpid(-1, POSIX::WNOHANG())) > 0) {
  548.                     my $status = $? >> 8;
  549.                     #error "got child exit $status";
  550.                     if ($status) {
  551.                         my $msg = "server has died with status $status";
  552.                         $self->failed_msg("\n$msg");
  553.                         Apache::TestRun->new(test_config => $config)->scan_core;
  554.                         kill SIGTERM => $$;
  555.                     }
  556.                 }
  557.             };
  558.         }
  559.  
  560.         defined(my $pid = fork) or die "Can't fork: $!";
  561.         unless ($pid) { # child
  562.             my $status = system "$cmd";
  563.             if ($status) {
  564.                 $status  = $? >> 8;
  565.                 #error "httpd didn't start! $status";
  566.             }
  567.             CORE::exit $status;
  568.         }
  569.     }
  570.  
  571.     while ($old_pid and $old_pid == $self->pid) {
  572.         warning "old pid file ($old_pid) still exists";
  573.         sleep 1;
  574.     }
  575.  
  576.     my $version = $self->{version};
  577.     my $mpm = $config->{mpm} || "";
  578.     $mpm = "($mpm MPM)" if $mpm;
  579.     print "using $version $mpm\n";
  580.  
  581.     my $timeout = $vars->{startup_timeout} ||
  582.                   $ENV{APACHE_TEST_STARTUP_TIMEOUT} ||
  583.                   60;
  584.  
  585.     my $start_time = time;
  586.     my $preamble = "${CTRL_M}waiting $timeout seconds for server to start: ";
  587.     print $preamble unless COLOR;
  588.     while (1) {
  589.         my $delta = time - $start_time;
  590.         print COLOR
  591.             ? ($preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0])
  592.             : '.';
  593.         sleep 1;
  594.         if ($self->pid) {
  595.             print $preamble, "ok (waited $delta secs)\n";
  596.             last;
  597.         }
  598.         elsif ($delta > $timeout) {
  599.             my $suggestion = $timeout + 300;
  600.             print $preamble, "not ok\n";
  601.             error <<EOI;
  602. giving up after $delta secs. If you think that your system
  603. is slow or overloaded try again with a longer timeout value.
  604. by setting the environment variable APACHE_TEST_STARTUP_TIMEOUT
  605. to a high value (e.g. $suggestion) and repeat the last command.
  606. EOI
  607.             last;
  608.         }
  609.     }
  610.  
  611.     # now that the server has started don't abort the test run if it
  612.     # dies
  613.     $SIG{CHLD} = $old_sig || 'DEFAULT';
  614.  
  615.     if (my $pid = $self->pid) {
  616.         print "server $self->{name} started\n";
  617.  
  618.         my $vh = $config->{vhosts};
  619.         my $by_port = sub { $vh->{$a}->{port} <=> $vh->{$b}->{port} };
  620.  
  621.         for my $module (sort $by_port keys %$vh) {
  622.             print "server $vh->{$module}->{name} listening ($module)\n",
  623.         }
  624.  
  625.         if ($config->configure_proxy) {
  626.             print "tests will be proxied through $vars->{proxy}\n";
  627.         }
  628.     }
  629.     else {
  630.         $self->failed_msg("server failed to start!");
  631.         return 0;
  632.     }
  633.  
  634.     return 1 if $self->wait_till_is_up($timeout);
  635.  
  636.     $self->failed_msg("failed to start server!");
  637.     return 0;
  638. }
  639.  
  640.  
  641. # wait till the server is up and return 1
  642. # if the waiting times out returns 0
  643. sub wait_till_is_up {
  644.     my($self, $timeout) = @_;
  645.     my $config = $self->{config};
  646.     my $sleep_interval = 1; # secs
  647.  
  648.     my $server_up = sub {
  649.         local $SIG{__WARN__} = sub {}; #avoid "cannot connect ..." warnings
  650.         # avoid fatal errors when LWP is not available
  651.         my $r = eval { Apache::TestRequest::GET('/index.html') };
  652.         return !$@ && defined $r ? $r->code : 0;
  653.     };
  654.  
  655.     if ($server_up->()) {
  656.         return 1;
  657.     }
  658.  
  659.     my $start_time = time;
  660.     my $preamble = "${CTRL_M}still waiting for server to warm up: ";
  661.     print $preamble unless COLOR;
  662.     while (1) {
  663.         my $delta = time - $start_time;
  664.         print COLOR
  665.             ? ($preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0])
  666.             : '.';
  667.         sleep $sleep_interval;
  668.         if ($server_up->()) {
  669.             print "${CTRL_M}the server is up (waited $delta secs)             \n";
  670.             return 1;
  671.         }
  672.         elsif ($delta > $timeout) {
  673.             print "${CTRL_M}the server is down, giving up after $delta secs\n";
  674.             return 0;
  675.         }
  676.         else {
  677.             # continue
  678.         }
  679.     }
  680. }
  681.  
  682. 1;
  683.