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