1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
# Script to test auto flush on fork/exec/system/qx. The idea is to
# print "Pe" to a file from a parent process and "rl" to the same file
# from a child process. If buffers are flushed appropriately, the
# file should contain "Perl". We'll see...
use Config;
use warnings;
use strict;
# This attempts to mirror the #ifdef forest found in perl.h so that we
# know when to run these tests. If that forest ever changes, change
# it here too or expect test gratuitous test failures.
my $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0;
my $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0;
my $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0;
my $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0;
skip_all('fflush(NULL) or equivalent not available')
unless $useperlio || $fflushNULL || $fflushall;
plan(tests => 7);
my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
$runperl .= qq{ "-I../lib"};
sub file_eq {
my $f = shift;
my $val = shift;
open IN, $f or die "open $f: $!";
chomp(my $line = <IN>);
close IN;
print "# got $line\n";
print "# expected $val\n";
return $line eq $val;
}
# This script will be used as the command to execute from
# child processes
my $ffprog = tempfile();
open PROG, "> $ffprog" or die "open $ffprog: $!";
print PROG <<'EOF';
my $f = shift;
my $str = shift;
open OUT, ">> $f" or die "open $f: $!";
print OUT $str;
close OUT;
EOF
;
close PROG or die "close $ffprog: $!";;
$| = 0; # we want buffered output
# Test flush on fork/exec
if (!$d_fork) {
print "ok 1 # skipped: no fork\n";
} else {
my $f = tempfile();
open OUT, "> $f" or die "open $f: $!";
print OUT "Pe";
my $pid = fork;
if ($pid) {
# Parent
wait;
close OUT or die "close $f: $!";
} elsif (defined $pid) {
# Kid
print OUT "r";
my $command = qq{$runperl "$ffprog" "$f" "l"};
print "# $command\n";
exec $command or die $!;
exit;
} else {
# Bang
die "fork: $!";
}
print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n";
}
# Test flush on system/qx/pipe open
my %subs = (
"system" => sub {
my $c = shift;
system $c;
},
"qx" => sub {
my $c = shift;
qx{$c};
},
"popen" => sub {
my $c = shift;
open PIPE, "$c|" or die "$c: $!";
close PIPE;
},
);
my $t = 2;
for (qw(system qx popen)) {
my $code = $subs{$_};
my $f = tempfile();
my $command = qq{$runperl $ffprog "$f" "rl"};
open OUT, "> $f" or die "open $f: $!";
print OUT "Pe";
close OUT or die "close $f: $!";;
print "# $command\n";
$code->($command);
print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
++$t;
}
my $cmd = _create_runperl(
switches => ['-l'],
prog =>
sprintf('print qq[ok $_] for (%d..%d)', $t, $t+2));
print "# cmd = '$cmd'\n";
open my $CMD, "$cmd |" or die "Can't open pipe to '$cmd': $!";
while (<$CMD>) {
system("$runperl -e 0");
print;
}
close $CMD;
$t += 3;
curr_test($t);
|
