1N/A#!./perl
1N/A
1N/ABEGIN {
1N/A chdir 't' if -d 't';
1N/A @INC = '../lib';
1N/A require './test.pl';
1N/A}
1N/A
1N/A# Script to test auto flush on fork/exec/system/qx. The idea is to
1N/A# print "Pe" to a file from a parent process and "rl" to the same file
1N/A# from a child process. If buffers are flushed appropriately, the
1N/A# file should contain "Perl". We'll see...
1N/Ause Config;
1N/Ause warnings;
1N/Ause strict;
1N/A
1N/A# This attempts to mirror the #ifdef forest found in perl.h so that we
1N/A# know when to run these tests. If that forest ever changes, change
1N/A# it here too or expect test gratuitous test failures.
1N/Amy $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0;
1N/Amy $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0;
1N/Amy $d_sfio = defined $Config{d_sfio} ? $Config{d_sfio} eq 'define' ? 1 : 0 : 0;
1N/Amy $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0;
1N/Amy $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0;
1N/A
1N/Aif ($useperlio || $fflushNULL || $d_sfio) {
1N/A print "1..7\n";
1N/A} else {
1N/A if ($fflushall) {
1N/A print "1..7\n";
1N/A } else {
1N/A print "1..0 # Skip: fflush(NULL) or equivalent not available\n";
1N/A exit;
1N/A }
1N/A}
1N/A
1N/Amy $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
1N/A$runperl .= qq{ "-I../lib"};
1N/A
1N/Amy @delete;
1N/A
1N/AEND {
1N/A for (@delete) {
1N/A unlink $_ or warn "unlink $_: $!";
1N/A }
1N/A}
1N/A
1N/Asub file_eq {
1N/A my $f = shift;
1N/A my $val = shift;
1N/A
1N/A open IN, $f or die "open $f: $!";
1N/A chomp(my $line = <IN>);
1N/A close IN;
1N/A
1N/A print "# got $line\n";
1N/A print "# expected $val\n";
1N/A return $line eq $val;
1N/A}
1N/A
1N/A# This script will be used as the command to execute from
1N/A# child processes
1N/Aopen PROG, "> ff-prog" or die "open ff-prog: $!";
1N/Aprint PROG <<'EOF';
1N/Amy $f = shift;
1N/Amy $str = shift;
1N/Aopen OUT, ">> $f" or die "open $f: $!";
1N/Aprint OUT $str;
1N/Aclose OUT;
1N/AEOF
1N/A ;
1N/Aclose PROG or die "close ff-prog: $!";;
1N/Apush @delete, "ff-prog";
1N/A
1N/A$| = 0; # we want buffered output
1N/A
1N/A# Test flush on fork/exec
1N/Aif (!$d_fork) {
1N/A print "ok 1 # skipped: no fork\n";
1N/A} else {
1N/A my $f = "ff-fork-$$";
1N/A open OUT, "> $f" or die "open $f: $!";
1N/A print OUT "Pe";
1N/A my $pid = fork;
1N/A if ($pid) {
1N/A # Parent
1N/A wait;
1N/A close OUT or die "close $f: $!";
1N/A } elsif (defined $pid) {
1N/A # Kid
1N/A print OUT "r";
1N/A my $command = qq{$runperl "ff-prog" "$f" "l"};
1N/A print "# $command\n";
1N/A exec $command or die $!;
1N/A exit;
1N/A } else {
1N/A # Bang
1N/A die "fork: $!";
1N/A }
1N/A
1N/A print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n";
1N/A push @delete, $f;
1N/A}
1N/A
1N/A# Test flush on system/qx/pipe open
1N/Amy %subs = (
1N/A "system" => sub {
1N/A my $c = shift;
1N/A system $c;
1N/A },
1N/A "qx" => sub {
1N/A my $c = shift;
1N/A qx{$c};
1N/A },
1N/A "popen" => sub {
1N/A my $c = shift;
1N/A open PIPE, "$c|" or die "$c: $!";
1N/A close PIPE;
1N/A },
1N/A );
1N/Amy $t = 2;
1N/Afor (qw(system qx popen)) {
1N/A my $code = $subs{$_};
1N/A my $f = "ff-$_-$$";
1N/A my $command = qq{$runperl "ff-prog" "$f" "rl"};
1N/A open OUT, "> $f" or die "open $f: $!";
1N/A print OUT "Pe";
1N/A close OUT or die "close $f: $!";;
1N/A print "# $command\n";
1N/A $code->($command);
1N/A print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
1N/A push @delete, $f;
1N/A ++$t;
1N/A}
1N/A
1N/Amy $cmd = _create_runperl(
1N/A switches => ['-l'],
1N/A prog =>
1N/A sprintf('print qq[ok $_] for (%d..%d)', $t, $t+2));
1N/Aprint "# cmd = '$cmd'\n";
1N/Aopen my $CMD, "$cmd |" or die "Can't open pipe to '$cmd': $!";
1N/Awhile (<$CMD>) {
1N/A system("$runperl -e 0");
1N/A print;
1N/A}
1N/Aclose $CMD;
1N/A$t += 3;