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