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