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..4\n";
  27 } else {
  28     if ($fflushall) {
  29         print "1..4\n";
  30     } else {
  31         print "1..0 # Skip: fflush(NULL) or equivalent not available\n";
  32         exit;
  33     }
  34 }
  35
  36 my $runperl = qq{$^X "-I../lib"};
  37 my @delete;
  38
  39 END {
  40     for (@delete) {
  41         unlink $_ or warn "unlink $_: $!";
  42     }
  43 }
  44
  45 sub file_eq {
  46     my $f   = shift;
  47     my $val = shift;
  48
  49     open IN, $f or die "open $f: $!";
  50     chomp(my $line = <IN>);
  51     close IN;
  52
  53     print "# got $line\n";
  54     print "# expected $val\n";
  55     return $line eq $val;
  56 }
  57
  58 # This script will be used as the command to execute from
  59 # child processes
  60 open PROG, "> ff-prog" or die "open ff-prog: $!";
  61 print PROG <<'EOF';
  62 my $f = shift;
  63 my $str = shift;
  64 open OUT, ">> $f" or die "open $f: $!";
  65 print OUT $str;
  66 close OUT;
  67 EOF
  68     ;
  69 close PROG;
  70 push @delete, "ff-prog";
  71
  72 $| = 0; # we want buffered output
  73
  74 # Test flush on fork/exec
  75 if (!$d_fork) {
  76     print "ok 1 # skipped: no fork\n";
  77 } else {
  78     my $f = "ff-fork-$$";
  79     open OUT, "> $f" or die "open $f: $!";
  80     print OUT "Pe";
  81     my $pid = fork;
  82     if ($pid) {
  83         # Parent
  84         wait;
  85         close OUT or die "close $f: $!";
  86     } elsif (defined $pid) {
  87         # Kid
  88         print OUT "r";
  89         my $command = qq{$runperl "ff-prog" "$f" "l"};
  90         print "# $command\n";
  91         exec $command or die $!;
  92         exit;
  93     } else {
  94         # Bang
  95         die "fork: $!";
  96     }
  97
  98     print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n";
  99     push @delete, $f;
 100 }
 101
 102 # Test flush on system/qx/pipe open
 103 my %subs = (
 104             "system" => sub {
 105                 my $c = shift;
 106                 system $c;
 107             },
 108             "qx"     => sub {
 109                 my $c = shift;
 110                 qx{$c};
 111             },
 112             "popen"  => sub {
 113                 my $c = shift;
 114                 open PIPE, "$c|" or die "$c: $!";
 115                 close PIPE;
 116             },
 117             );
 118 my $t = 2;
 119 for (qw(system qx popen)) {
 120     my $code    = $subs{$_};
 121     my $f       = "ff-$_-$$";
 122     my $command = qq{$runperl "ff-prog" "$f" "rl"};
 123     open OUT, "> $f" or die "open $f: $!";
 124     print OUT "Pe";
 125     close OUT;
 126     print "# $command\n";
 127     $code->($command);
 128     print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
 129     push @delete, $f;
 130     ++$t;
 131 }