On Fri, 4 Jan 2002, Stas Bekman wrote:
> Found the problem, temporary replace
>
> $child_pid = open $child_in_pipe, "|$cmd";
>
> with:
>
> system "$cmd &";
>
> in Apache-Test/lib/Apache/TestServer.pm
>
> the way it was before (well sort of, it's not good in failure cases, but
> at least it starts)
>
> this is because of my latest patch to make t/TEST immediately detect
> failures. Any ideas why this doesn't work with 1.3? Something goes wrong
> with the spawned process.
This seems to work with 1.3 and 2.0:
my $pid = fork();
unless ($pid) {
my $status = system "$cmd";
if ($status) {
$status = $? >> 8;
error "httpd didn't start! $status";
}
CORE::exit $status;
}
instead of system "$cmd &" as it was originally. In this case I can get to
the return status' value with CHLD sighandler.
Surprisingly for 2.0 it's enough to say:
$status = system "httpd ...";
and everything is cool, since system returns almost immediately. Not with
1.3, though it restarts the same way (I guess not exactly the same).
please test this patch (against current cvs) and if it's good I'll commit
it. (it includes all my latest status propagation work, which is not
committed)
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.80
diff -u -r1.80 TestRun.pm
--- Apache-Test/lib/Apache/TestRun.pm 31 Dec 2001 09:09:43 -0000 1.80
+++ Apache-Test/lib/Apache/TestRun.pm 3 Jan 2002 19:14:55 -0000
@@ -17,6 +17,7 @@
use Config;
use constant STARTUP_TIMEOUT => 300; # secs (good for extreme debug cases)
+use subs qw(exit_shell exit_perl);
my %core_files = ();
@@ -137,7 +138,7 @@
my @invalid_argv = @{ $self->{argv} };
if (@invalid_argv) {
error "unknown opts or test names: @invalid_argv";
- exit;
+ exit_perl 0;
}
}
@@ -258,16 +259,17 @@
return unless $_[0] =~ /^Failed/i; #dont catch Test::ok failures
$server->stop(1) if $opts->{'start-httpd'};
$server->failed_msg("error running tests");
+ exit_perl 0;
};
$SIG{INT} = sub {
if ($caught_sig_int++) {
warning "\ncaught SIGINT";
- exit;
+ exit_perl 0;
}
warning "\nhalting tests";
$server->stop if $opts->{'start-httpd'};
- exit;
+ exit_perl 0;
};
#try to make sure we scan for core no matter what happens
@@ -383,17 +385,19 @@
for (@exit_opts) {
next unless exists $self->{opts}->{$_};
my $method = "opt_$_";
- exit if $self->$method();
+ exit_perl $self->$method();
}
if ($self->{opts}->{'stop-httpd'}) {
+ my $ok = 1;
if ($self->{server}->ping) {
- $self->{server}->stop;
+ $ok = $self->{server}->stop;
+ $ok = $ok < 0 ? 0 : 1; # adjust to 0/1 logic
}
else {
warning "server $self->{server}->{name} is not running";
}
- exit;
+ exit_perl $ok ;
}
}
@@ -407,7 +411,7 @@
($test_config->{APXS} ?
"an apxs other than $test_config->{APXS}" : "apxs").
" or put either in your PATH";
- exit 1;
+ exit_perl 0;
}
my $opts = $self->{opts};
@@ -427,7 +431,8 @@
}
if ($opts->{'start-httpd'}) {
- exit 1 unless $server->start;
+ my $status = $server->start;
+ exit_perl 0 unless $status;
}
elsif ($opts->{'run-tests'}) {
my $is_up = $server->ping
@@ -436,7 +441,7 @@
&& $server->wait_till_is_up(STARTUP_TIMEOUT));
unless ($is_up) {
error "server is not ready yet, try again.";
- exit;
+ exit_perl 0;
}
}
}
@@ -464,7 +469,7 @@
sub stop {
my $self = shift;
- $self->{server}->stop if $self->{opts}->{'stop-httpd'};
+ return $self->{server}->stop if $self->{opts}->{'stop-httpd'};
}
sub new_test_config {
@@ -491,13 +496,10 @@
}
close $sh;
- open $sh, "|$binsh" or die;
- my @cmd = ("ulimit -c unlimited\n",
- "exec $0 @ARGV");
- warning "setting ulimit to allow core [EMAIL PROTECTED]";
- print $sh @cmd;
- close $sh;
- exit; #exec above will take over
+ my $command = "ulimit -c unlimited; $0 @ARGV";
+ warning "setting ulimit to allow core files\n$command";
+ exec $command;
+ die "exec $command has failed"; # shouldn't be reached
}
sub set_ulimit {
@@ -548,13 +550,13 @@
warning "forcing Apache::TestConfig object save";
$self->{test_config}->save;
warning "run 't/TEST -clean' to clean up before continuing";
- exit 1;
+ exit_perl 0;
}
}
if ($self->{opts}->{configure}) {
warning "reconfiguration done";
- exit;
+ exit_perl 1;
}
$self->try_exit_opts;
@@ -770,5 +772,18 @@
}
+# in idiomatic perl functions return 1 on success 0 on
+# failure. Shell expects the opposite behavior. So this function
+# reverses the status.
+sub exit_perl {
+ exit_shell $_[0] ? 0 : 1;
+}
+
+# expects shell's exit status values (0==success)
+sub exit_shell {
+# require Carp;
+# Carp::cluck('exiting');
+ CORE::exit $_[0];
+}
1;
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.47
diff -u -r1.47 TestServer.pm
--- Apache-Test/lib/Apache/TestServer.pm 31 Dec 2001 10:58:22 -0000
1.47
+++ Apache-Test/lib/Apache/TestServer.pm 3 Jan 2002 19:14:55 -0000
@@ -427,13 +427,23 @@
$SIG{CHLD} = sub {
while ((my $child = waitpid(-1, POSIX::WNOHANG())) > 0) {
my $status = $? >> 8;
+ #error "got child exit $status";
if ($status) {
$self->failed_msg("\nserver has died with status $status");
kill SIGTERM => $$;
}
}
};
- $child_pid = open $child_in_pipe, "|$cmd";
+
+ my $pid = fork();
+ unless ($pid) {
+ 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) {
_____________________________________________________________________
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/
