I've figured out that I have to run many times t/TEST -run
until it successfully pings the server under t/TEST -d, so I want the
polling functionality for -run too. Since now we have 3 places where the
polling happens (start/ping/run), this patch:
- refactors the polling code into Apache::TestServer::wait_till_is_up()
- adds -poll option which will block until the server starts for -ping and
-run opts. (which takes over the -ping=block which I've added this
morning).
issues:
- any reason for not making -poll turned on by default for -run?
Index: Apache-Test/lib/Apache/TestRun.pm
===================================================================
RCS file:
/home/cvs/httpd-test/perl-framework/Apache-Test/lib/Apache/TestRun.pm,v
retrieving revision 1.69
diff -u -r1.69 TestRun.pm
--- Apache-Test/lib/Apache/TestRun.pm 2001/11/22 03:11:38 1.69
+++ Apache-Test/lib/Apache/TestRun.pm 2001/11/22 15:59:10
@@ -14,11 +14,13 @@
use Getopt::Long qw(GetOptions);
use Config;
+use constant STARTUP_TIMEOUT => 300; # secs (good for extreme debug cases)
+
my @std_run = qw(start-httpd run-tests stop-httpd);
-my @others = qw(verbose configure clean help ssl http11);
+my @others = qw(verbose configure clean help ping poll ssl http11);
my @flag_opts = (@std_run, @others);
my @string_opts = qw(order);
-my @ostring_opts = qw(proxy ping);
+my @ostring_opts = qw(proxy);
my @debug_opts = qw(debug);
my @num_opts = qw(times);
my @list_opts = qw(preamble postamble breakpoint);
@@ -39,7 +41,8 @@
'help' => 'display this message',
'preamble' => 'config to add at the beginning of httpd.conf',
'postamble' => 'config to add at the end of httpd.conf',
- 'ping[=block]' => 'test if server is running or port in use',
+ 'ping' => 'test if server is running or port in use',
+ 'poll' => 'poll the server until it starts',
'debug[=name]' => 'start server under debugger name (e.g. gdb, ddd,
...)',
'breakpoint=bp' => 'set breakpoints (multiply bp can be set)',
'header' => "add headers to (".join('|', @request_opts).")
request",
@@ -202,6 +205,12 @@
$opts{debug} = 1;
}
+ # -poll should be used only with -run-tests or -ping
+ if ( $opts{poll} && !($opts{'run-tests'} || $opts{ping}) ) {
+ error "-poll is valid only with either -run-tests or -ping";
+ exit;
+ }
+
# breakpoint automatically turns the debug mode on
if (@{ $opts{breakpoint} }) {
$opts{debug} ||= 1;
@@ -416,7 +425,9 @@
exit 1 unless $server->start;
}
elsif ($opts->{'run-tests'}) {
- if (!$server->ping) {
+ my $is_up = $server->ping ||
+ ($self->{opts}->{poll} &&
$server->wait_till_is_up(STARTUP_TIMEOUT));
+ unless ($is_up) {
error "server is not ready yet, try again.";
exit;
}
@@ -634,24 +645,8 @@
return 1;
}
- my $opt = $self->{opts}->{ping} || '';
- if ($opt eq 'block') {
- my $wait_secs = 300; # should be enough for extreme debug cases
- my $start_time = time;
- my $preamble = "\rwaiting for server $name to come up: ";
- while (1) {
- my $delta = time - $start_time;
- print $preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0];
- sleep 1;
- if ($server->ping) {
- print $preamble, "\rserver $name is now up (waited $delta
secs) \n";
- last;
- }
- elsif ($delta > $wait_secs) {
- print $preamble, "giving up after $delta secs\n";
- last;
- }
- }
+ if ($self->{opts}->{poll}) {
+ $server->wait_till_is_up(STARTUP_TIMEOUT);
}
else {
warning "no server is running on $name";
Index: Apache-Test/lib/Apache/TestServer.pm
===================================================================
RCS file:
/home/cvs/httpd-test/perl-framework/Apache-Test/lib/Apache/TestServer.pm,v
retrieving revision 1.41
diff -u -r1.41 TestServer.pm
--- Apache-Test/lib/Apache/TestServer.pm 2001/11/22 03:13:04 1.41
+++ Apache-Test/lib/Apache/TestServer.pm 2001/11/22 15:59:10
@@ -426,7 +426,7 @@
$mpm = "($mpm MPM)" if $mpm;
print "using $version $mpm\n";
- my $wait_secs = 60; # XXX: make a constant?
+ my $timeout = 60; # secs XXX: make a constant?
my $start_time = time;
my $preamble = "\rwaiting for server to start: ";
@@ -438,7 +438,7 @@
print $preamble, "ok (waited $delta secs)\n";
last;
}
- elsif ($delta > $wait_secs) {
+ elsif ($delta > $timeout) {
print $preamble, "giving up after $delta secs\n";
last;
}
@@ -463,6 +463,20 @@
return 0;
}
+ $self->wait_till_is_up($timeout) && return 1;
+
+ $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
$config->http_raw_get('/index.html');
@@ -472,24 +486,21 @@
return 1;
}
- $start_time = time;
- $preamble = "\rstill waiting for server to warm up: ";
+ my $start_time = time;
+ my $preamble = "\rstill waiting for server to warm up: ";
while (1) {
my $delta = time - $start_time;
print $preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0];
- sleep 1;
+ sleep $sleep_interval;
if ($server_up->()) {
- print $preamble, "ok (waited $delta secs)\n";
- last;
+ print "\rthe server is up (waited $delta secs) \n";
+ return 1;
}
- elsif ($delta > $wait_secs) {
- print $preamble, "giving up after $delta secs\n";
- last;
+ elsif ($delta > $timeout) {
+ print "\rthe server is down, giving up after $delta secs\n";
+ return 0;
}
}
-
- $self->failed_msg("failed to start server!");
- return 0;
}
1;
_____________________________________________________________________
Stas Bekman JAm_pH -- Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide http://perl.apache.org/guide
mailto:[EMAIL PROTECTED] http://ticketmaster.com http://apacheweek.com
http://singlesheaven.com http://perl.apache.org http://perlmonth.com/
