Test autoflush on fork (Was: Should I remove something?)

Message-ID: <Pine.LNX.4.21.0104302213190.19002-100000@localhost.localdomain>

p4raw-id: //depot/perl@9923

diff --git a/MANIFEST b/MANIFEST
index 988302e..39e90ef 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1432,6 +1432,7 @@ t/comp/use.t              See if pragmas work
 t/harness              Finer diagnostics from test suite
 t/io/argv.t            See if ARGV stuff works
 t/io/dup.t             See if >& works right
+t/io/fflush.t          See if auto-flush on fork/exec/system/qx works
 t/io/fs.t              See if directory manipulations work
 t/io/inplace.t         See if inplace editing works
 t/io/iprefix.t         See if inplace editing works with prefixes

diff --git a/t/io/fflush.t b/t/io/fflush.t
new file mode 100644 (file)
index 0000000..8c6bd08
--- /dev/null
+++ b/t/io/fflush.t
@@ -0,0 +1,125 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+# Script to test auto flush on fork/exec/system/qx.  The idea is to
+# print "Pe" to a file from a parent process and "rl" to the same file
+# from a child process.  If buffers are flushed appropriately, the
+# file should contain "Perl".  We'll see...
+use Config;
+use warnings;
+use strict;
+
+# This attempts to mirror the #ifdef forest found in perl.h so that we
+# know when to run these tests.  If that forest ever changes, change
+# it here too or expect test gratuitous test failures.
+if ($Config{useperlio} || $Config{fflushNULL} || $Config{d_sfio}) {
+    print "1..4\n";
+} else {
+    if ($Config{fflushall}) {
+       print "1..4\n";
+    } else {
+       print "1..0 # Skip: fflush(NULL) or equivalent not available\n";
+        exit;
+    }
+}
+
+my $runperl = qq{$^X "-I../lib"};
+my @delete;
+
+END {
+    for (@delete) {
+       unlink $_ or warn "unlink $_: $!";
+    }
+}
+
+sub file_eq {
+    my $f   = shift;
+    my $val = shift;
+
+    open IN, $f or die "open $f: $!";
+    chomp(my $line = <IN>);
+    close IN;
+
+    print "# got $line\n";
+    print "# expected $val\n";
+    return $line eq $val;
+}
+
+# This script will be used as the command to execute from
+# child processes
+open PROG, "> ff-prog" or die "open ff-prog: $!";
+print PROG <<'EOF';
+my $f = shift;
+my $str = shift;
+open OUT, ">> $f" or die "open $f: $!";
+print OUT $str;
+close OUT;
+EOF
+    ;
+close PROG;
+push @delete, "ff-prog";
+
+$| = 0; # we want buffered output
+
+# Test flush on fork/exec
+if ($Config{d_fork} ne "define") {
+    print "ok 1 # skipped: no fork\n";
+} else {
+    my $f = "ff-fork-$$";
+    open OUT, "> $f" or die "open $f: $!";
+    print OUT "Pe";
+    my $pid = fork;
+    if ($pid) {
+       # Parent
+       wait;
+       close OUT or die "close $f: $!";
+    } elsif (defined $pid) {
+       # Kid
+       print OUT "r";
+       my $command = qq{$runperl "ff-prog" "$f" "l"};
+       print "# $command\n";
+       exec $command or die $!;
+       exit;
+    } else {
+       # Bang
+       die "fork: $!";
+    }
+
+    print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n";
+    push @delete, $f;
+}
+
+# Test flush on system/qx/pipe open
+my %subs = (
+            "system" => sub {
+                my $c = shift;
+                system $c;
+            },
+            "qx"     => sub {
+                my $c = shift;
+                qx{$c};
+            },
+            "popen"  => sub {
+                my $c = shift;
+                open PIPE, "$c|" or die "$c: $!";
+                close PIPE;
+            },
+            );
+my $t = 2;
+for (qw(system qx popen)) {
+    my $code    = $subs{$_};
+    my $f       = "ff-$_-$$";
+    my $command = qq{$runperl "ff-prog" "$f" "rl"};
+    open OUT, "> $f" or die "open $f: $!";
+    print OUT "Pe";
+    print "# $command\n";
+    $code->($command);
+    close OUT;
+    print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
+    push @delete, $f;
+    ++$t;
+}