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