This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
056517fd3e3931ce2667a17908fd4569e7c9f0a6
[perl5.git] / 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 sub file_eq {
41     my $f   = shift;
42     my $val = shift;
43
44     open IN, $f or die "open $f: $!";
45     chomp(my $line = <IN>);
46     close IN;
47
48     print "# got $line\n";
49     print "# expected $val\n";
50     return $line eq $val;
51 }
52
53 # This script will be used as the command to execute from
54 # child processes
55 my $ffprog = tempfile();
56 open PROG, "> $ffprog" or die "open $ffprog: $!";
57 print PROG <<'EOF';
58 my $f = shift;
59 my $str = shift;
60 open OUT, ">> $f" or die "open $f: $!";
61 print OUT $str;
62 close OUT;
63 EOF
64     ;
65 close PROG or die "close $ffprog: $!";;
66
67 $| = 0; # we want buffered output
68
69 # Test flush on fork/exec
70 if (!$d_fork) {
71     print "ok 1 # skipped: no fork\n";
72 } else {
73     my $f = tempfile();
74     open OUT, "> $f" or die "open $f: $!";
75     print OUT "Pe";
76     my $pid = fork;
77     if ($pid) {
78         # Parent
79         wait;
80         close OUT or die "close $f: $!";
81     } elsif (defined $pid) {
82         # Kid
83         print OUT "r";
84         my $command = qq{$runperl "$ffprog" "$f" "l"};
85         print "# $command\n";
86         exec $command or die $!;
87         exit;
88     } else {
89         # Bang
90         die "fork: $!";
91     }
92
93     print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n";
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       = tempfile();
116     my $command = qq{$runperl $ffprog "$f" "rl"};
117     open OUT, "> $f" or die "open $f: $!";
118     print OUT "Pe";
119     close OUT or die "close $f: $!";;
120     print "# $command\n";
121     $code->($command);
122     print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
123     ++$t;
124 }
125
126 my $cmd = _create_runperl(
127                           switches => ['-l'],
128                           prog =>
129                           sprintf('print qq[ok $_] for (%d..%d)', $t, $t+2));
130 print "# cmd = '$cmd'\n";
131 open my $CMD, "$cmd |" or die "Can't open pipe to '$cmd': $!";
132 while (<$CMD>) {
133     system("$runperl -e 0");
134     print;
135 }
136 close $CMD;
137 $t += 3;