Suppress a few compilation warnings in pp_hot.c.
[p5sagit/p5-mst-13.2.git] / t / io / fflush.t
1 #!./perl
2
3 BEGIN {
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...
12 use Config;
13 use warnings;
14 use 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.
19 my $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0;
20 my $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0;
21 my $d_sfio = defined $Config{d_sfio} ? $Config{d_sfio} eq 'define' ? 1 : 0 : 0;
22 my $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0;
23 my $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0;
24
25 if ($useperlio || $fflushNULL || $d_sfio) {
26     print "1..4\n";
27 } else {
28     if ($fflushall) {
29         print "1..4\n";
30     } else {
31         print "1..0 # Skip: fflush(NULL) or equivalent not available\n";
32         exit;
33     }
34 }
35
36 my $runperl = qq{$^X "-I../lib"};
37 my @delete;
38
39 END {
40     for (@delete) {
41         unlink $_ or warn "unlink $_: $!";
42     }
43 }
44
45 sub 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
60 open PROG, "> ff-prog" or die "open ff-prog: $!";
61 print PROG <<'EOF';
62 my $f = shift;
63 my $str = shift;
64 open OUT, ">> $f" or die "open $f: $!";
65 print OUT $str;
66 close OUT;
67 EOF
68     ;
69 close PROG or die "close ff-prog: $!";;
70 push @delete, "ff-prog";
71
72 $| = 0; # we want buffered output
73
74 # Test flush on fork/exec
75 if (!$d_fork) {
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
103 my %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             );
118 my $t = 2;
119 for (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";
125     close OUT or die "close $f: $!";;
126     print "# $command\n";
127     $code->($command);
128     print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
129     push @delete, $f;
130     ++$t;
131 }