t/io/fflush.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 # Script to test auto flush on fork/exec/system/qx.  The idea is to
   9 # print "Pe" to a file from a parent process and "rl" to the same file
  10 # from a child process.  If buffers are flushed appropriately, the
  11 # file should contain "Perl".  We'll see...
  12 use Config;
  13 use warnings;
  14 use strict;
  15
  16 # This attempts to mirror the #ifdef forest found in perl.h so that we
  17 # know when to run these tests.  If that forest ever changes, change
  18 # it here too or expect test gratuitous test failures.
  19 my $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0;
  20 my $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0;
  21 my $d_sfio = defined $Config{d_sfio} ? $Config{d_sfio} eq 'define' ? 1 : 0 : 0;
  22 my $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0;
  23 my $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0;
  24
  25 if ($useperlio || $fflushNULL || $d_sfio) {
  26     print "1..7\n";
  27 } else {
  28     if ($fflushall) {
  29         print "1..7\n";
  30     } else {
  31         print "1..0 # Skip: fflush(NULL) or equivalent not available\n";
  32         exit;
  33     }
  34 }
  35
  36 my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
  37 $runperl .= qq{ "-I../lib"};
  38
  39 my @delete;
  40
  41 END {
  42     for (@delete) {
  43         unlink $_ or warn "unlink $_: $!";
  44     }
  45 }
  46
  47 sub file_eq {
  48     my $f   = shift;
  49     my $val = shift;
  50
  51     open IN, $f or die "open $f: $!";
  52     chomp(my $line = <IN>);
  53     close IN;
  54
  55     print "# got $line\n";
  56     print "# expected $val\n";
  57     return $line eq $val;
  58 }
  59
  60 # This script will be used as the command to execute from
  61 # child processes
  62 open PROG, "> ff-prog" or die "open ff-prog: $!";
  63 print PROG <<'EOF';
  64 my $f = shift;
  65 my $str = shift;
  66 open OUT, ">> $f" or die "open $f: $!";
  67 print OUT $str;
  68 close OUT;
  69 EOF
  70     ;
  71 close PROG or die "close ff-prog: $!";;
  72 push @delete, "ff-prog";
  73
  74 $| = 0; # we want buffered output
  75
  76 # Test flush on fork/exec
  77 if (!$d_fork) {
  78     print "ok 1 # skipped: no fork\n";
  79 } else {
  80     my $f = "ff-fork-$$";
  81     open OUT, "> $f" or die "open $f: $!";
  82     print OUT "Pe";
  83     my $pid = fork;
  84     if ($pid) {
  85         # Parent
  86         wait;
  87         close OUT or die "close $f: $!";
  88     } elsif (defined $pid) {
  89         # Kid
  90         print OUT "r";
  91         my $command = qq{$runperl "ff-prog" "$f" "l"};
  92         print "# $command\n";
  93         exec $command or die $!;
  94         exit;
  95     } else {
  96         # Bang
  97         die "fork: $!";
  98     }
  99
 100     print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n";
 101     push @delete, $f;
 102 }
 103
 104 # Test flush on system/qx/pipe open
 105 my %subs = (
 106             "system" => sub {
 107                 my $c = shift;
 108                 system $c;
 109             },
 110             "qx"     => sub {
 111                 my $c = shift;
 112                 qx{$c};
 113             },
 114             "popen"  => sub {
 115                 my $c = shift;
 116                 open PIPE, "$c|" or die "$c: $!";
 117                 close PIPE;
 118             },
 119             );
 120 my $t = 2;
 121 for (qw(system qx popen)) {
 122     my $code    = $subs{$_};
 123     my $f       = "ff-$_-$$";
 124     my $command = qq{$runperl "ff-prog" "$f" "rl"};
 125     open OUT, "> $f" or die "open $f: $!";
 126     print OUT "Pe";
 127     close OUT or die "close $f: $!";;
 128     print "# $command\n";
 129     $code->($command);
 130     print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
 131     push @delete, $f;
 132     ++$t;
 133 }
 134
 135 my $cmd = qq[$runperl -e "print qq[ok \$_\\n] for ($t..$t+2)"];
 136 open my $CMD, "$cmd |" or die "Can't open pipe to '$cmd': $!";
 137 while (<$CMD>) {
 138     system("$runperl -e 0");
 139     print;
 140 }
 141 close $CMD;
 142 $t += 3;