t/io/fflush.t

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