perl-dev mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From Randy Kobes <ra...@theoryx5.uwinnipeg.ca>
Subject Re: t/SMOKE on win32
Date Fri, 03 Oct 2003 21:21:16 GMT
On Fri, 3 Oct 2003, Steve Hay wrote:

> I still worry that I've got something terribly wrong,
> though.  Surely it should at least start running some
> tests?  I was expecting it to either work, or else fail as
> before with the "Failed to dup STDOUT" error on certain
> (not-so-)random tests.
>
> Does my patch work on Linux?  If not then I have got it
> all wrong, and we're not still staring at a Win32 problem.

Actually, the patch did also make linux hang ... Here's
one which does work on linux - the intent here is to
dup/redirect STDOUT/STDERR before calling run3 $command,
so that run3 inherits the parent's STDOUT/STDERR/STDIN.

============================================================
Index: Apache-Test/lib/Apache/TestSmoke.pm
===================================================================
RCS file: /home/cvs/httpd-test/perl-framework/Apache-Test/lib/Apache/TestSmoke.pm,v
retrieving revision 1.23
diff -u -r1.23 TestSmoke.pm
--- Apache-Test/lib/Apache/TestSmoke.pm	12 Sep 2003 02:47:41 -0000	1.23
+++ Apache-Test/lib/Apache/TestSmoke.pm	3 Oct 2003 21:07:42 -0000
@@ -15,7 +15,8 @@
 use FindBin;
 use POSIX ();
 use Symbol ();
-
+use IPC::Run3;
+use File::Temp qw(tempfile);
 #use constant DEBUG => 1;

 # how many times to run all tests at the first iteration
@@ -111,7 +112,7 @@

     @{ $self->{tests} } = $self->get_tests($test_opts);

-    $self->{base_command} = "./TEST";
+    $self->{base_command} = "$^X $FindBin::Bin/TEST";

     # options common to all
     $self->{base_command} .= " -verbose" if $self->{verbose};
@@ -473,16 +474,13 @@
     # start server
     {
         my $command = $self->{start_command};
-        open my $pipe, "$command 2>&1|" or die "cannot fork: $!";
-        my $oldfh = select $pipe; $| = 1; select $oldfh;
-        # XXX: check startup success?
         my $started_ok = 0;
         my $log = '';
-        while (my $t = <$pipe>) {
-            $started_ok = 1 if $t =~ /started/;
-            $log .= $t;
+        unless ($log = run_command($command)) {
+            error "Error running $command";
+            exit 1;
         }
-        close $pipe;
+        $started_ok = 1 if $log =~ /started/;
         unless ($started_ok) {
             error "failed to start server\n $log";
             exit 1;
@@ -507,19 +505,14 @@
             my $fill = "." x ($max_len - length $test_name);
             $self->{total_tests_run}++;

-            open my $pipe, "$command $test 2>&1|" or die "cannot fork: $!";
-            my $oldfh = select $pipe; $| = 1; select $oldfh;
-
+            my $test_command = "$command $test";
             my $ok = 0;
             my $log = '';
-            while (<$pipe>) {
-                $log .= $_;
-
-                $ok = 1 if /All tests successful/;
+            unless ($log = run_command($test_command)) {
+                error "Error running $test_command";
+                exit 1;
             }
-            # it's normal for $command to exit with a failure status if tests
-            # fail, so we don't die/report it
-            close $pipe;
+            $ok = 1 if $log =~ /All tests successful/;

             my @core_files_msg = $self->Apache::TestRun::scan_core_incremental;

@@ -594,16 +587,13 @@
     # stop server
     {
         my $command = $self->{stop_command};
-        open my $pipe, "$command 2>&1|" or die "cannot fork: $!";
-        my $oldfh = select $pipe; $| = 1; select $oldfh;
-        # XXX: check stopup success?
         my $stopped_ok = 0;
         my $log = '';
-        while (my $t = <$pipe>) {
-            $stopped_ok = 1 if $t =~ /shutdown/;
-            $log .= $t;
+        unless ($log = run_command($command)) {
+            error "Error running $command";
+            exit 1;
         }
-        close $pipe;
+        $stopped_ok = 1 if $log =~ /shutdown/;
         unless ($stopped_ok) {
             error "failed to stop server\n $log";
             exit 1;
@@ -628,6 +618,46 @@
     }


+}
+
+sub run_command {
+    my $command = shift;
+    my ($fh, $file) = tempfile(UNLINK => 1);
+    open my $savout, ">&STDOUT" or do {
+        error "Can't dup STDOUT: $!";
+        return;
+    };
+    open my $saverr, ">&STDERR" or do {
+        error "Can't dup STDERR: $!";
+        return;
+    };
+    close STDOUT; close STDERR;
+    open STDOUT, '>', $file or do {
+        error "Can't redirect STDOUT: $!";
+        return;
+    };
+    open STDERR, '>&STDOUT' or do {
+        error "Can't redirect STDERR: $!";
+        return;
+    };
+    select STDERR; $| = 1;
+    select STDOUT; $| = 1;
+    run3 $command;
+    close STDOUT; close STDERR;
+    open STDOUT, '>&', $savout or do {
+        error "Can't restore STDOUT: $!";
+        return;
+    };
+    open STDERR, '>&', $saverr or do {
+        error "Can't restore STDERR: $!";
+        return;
+    };
+    close $savout; close $saverr;
+    local $/;
+    my $log = <$fh>;
+    close $fh;
+    print $log;
+    return $log;
 }

 sub report_start {
===============================================================

-- 
best regards,
randy


---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org


Mime
View raw message