Commit | Line | Data |
a43cb6b7 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
220939e6 |
6 | require './test.pl'; |
a43cb6b7 |
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. |
375927eb |
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) { |
a6dd0448 |
27 | print "1..7\n"; |
a43cb6b7 |
28 | } else { |
375927eb |
29 | if ($fflushall) { |
a6dd0448 |
30 | print "1..7\n"; |
a43cb6b7 |
31 | } else { |
32 | print "1..0 # Skip: fflush(NULL) or equivalent not available\n"; |
33 | exit; |
34 | } |
35 | } |
36 | |
a6dd0448 |
37 | my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X; |
38 | $runperl .= qq{ "-I../lib"}; |
39 | |
a43cb6b7 |
40 | my @delete; |
41 | |
42 | END { |
43 | for (@delete) { |
44 | unlink $_ or warn "unlink $_: $!"; |
45 | } |
46 | } |
47 | |
48 | sub file_eq { |
49 | my $f = shift; |
50 | my $val = shift; |
51 | |
52 | open IN, $f or die "open $f: $!"; |
53 | chomp(my $line = <IN>); |
54 | close IN; |
55 | |
56 | print "# got $line\n"; |
57 | print "# expected $val\n"; |
58 | return $line eq $val; |
59 | } |
60 | |
61 | # This script will be used as the command to execute from |
62 | # child processes |
63 | open PROG, "> ff-prog" or die "open ff-prog: $!"; |
64 | print PROG <<'EOF'; |
65 | my $f = shift; |
66 | my $str = shift; |
67 | open OUT, ">> $f" or die "open $f: $!"; |
68 | print OUT $str; |
69 | close OUT; |
70 | EOF |
71 | ; |
f126f811 |
72 | close PROG or die "close ff-prog: $!";; |
a43cb6b7 |
73 | push @delete, "ff-prog"; |
74 | |
75 | $| = 0; # we want buffered output |
76 | |
77 | # Test flush on fork/exec |
375927eb |
78 | if (!$d_fork) { |
a43cb6b7 |
79 | print "ok 1 # skipped: no fork\n"; |
80 | } else { |
81 | my $f = "ff-fork-$$"; |
82 | open OUT, "> $f" or die "open $f: $!"; |
83 | print OUT "Pe"; |
84 | my $pid = fork; |
85 | if ($pid) { |
86 | # Parent |
87 | wait; |
88 | close OUT or die "close $f: $!"; |
89 | } elsif (defined $pid) { |
90 | # Kid |
91 | print OUT "r"; |
92 | my $command = qq{$runperl "ff-prog" "$f" "l"}; |
93 | print "# $command\n"; |
94 | exec $command or die $!; |
95 | exit; |
96 | } else { |
97 | # Bang |
98 | die "fork: $!"; |
99 | } |
100 | |
101 | print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n"; |
102 | push @delete, $f; |
103 | } |
104 | |
105 | # Test flush on system/qx/pipe open |
106 | my %subs = ( |
107 | "system" => sub { |
108 | my $c = shift; |
109 | system $c; |
110 | }, |
111 | "qx" => sub { |
112 | my $c = shift; |
113 | qx{$c}; |
114 | }, |
115 | "popen" => sub { |
116 | my $c = shift; |
117 | open PIPE, "$c|" or die "$c: $!"; |
118 | close PIPE; |
119 | }, |
120 | ); |
121 | my $t = 2; |
122 | for (qw(system qx popen)) { |
123 | my $code = $subs{$_}; |
124 | my $f = "ff-$_-$$"; |
125 | my $command = qq{$runperl "ff-prog" "$f" "rl"}; |
126 | open OUT, "> $f" or die "open $f: $!"; |
127 | print OUT "Pe"; |
f126f811 |
128 | close OUT or die "close $f: $!";; |
a43cb6b7 |
129 | print "# $command\n"; |
130 | $code->($command); |
a43cb6b7 |
131 | print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n"; |
132 | push @delete, $f; |
133 | ++$t; |
134 | } |
a6dd0448 |
135 | |
220939e6 |
136 | my $cmd = _create_runperl( |
137 | switches => ['-l'], |
138 | prog => |
139 | sprintf('print qq[ok $_] for (%d..%d)', $t, $t+2)); |
140 | print "# cmd = '$cmd'\n"; |
a6dd0448 |
141 | open my $CMD, "$cmd |" or die "Can't open pipe to '$cmd': $!"; |
142 | while (<$CMD>) { |
143 | system("$runperl -e 0"); |
144 | print; |
145 | } |
146 | close $CMD; |
147 | $t += 3; |