This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make utf8::encode respect magic
[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 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);