Commit | Line | Data |
378cc40b |
1 | #!./perl |
2 | |
774d564b |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
20822f61 |
5 | @INC = '../lib'; |
774d564b |
6 | require Config; import Config; |
b6345914 |
7 | require './test.pl'; |
8 | |
9 | if (!$Config{'d_fork'}) { |
10 | skip_all("fork required to pipe"); |
11 | } |
12 | else { |
713cef20 |
13 | plan(tests => 24); |
774d564b |
14 | } |
15 | } |
16 | |
b6345914 |
17 | my $Perl = which_perl(); |
18 | |
19 | |
378cc40b |
20 | $| = 1; |
378cc40b |
21 | |
b6345914 |
22 | open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/'; |
23 | |
24 | printf PIPE "Xk %d - open |- || exec\n", curr_test(); |
25 | next_test(); |
26 | printf PIPE "oY %d - again\n", curr_test(); |
27 | next_test(); |
378cc40b |
28 | close PIPE; |
29 | |
b6345914 |
30 | SKIP: { |
31 | # Technically this should be TODO. Someone try it if you happen to |
32 | # have a vmesa machine. |
713cef20 |
33 | skip "Doesn't work here yet", 6 if $^O eq 'vmesa'; |
b6345914 |
34 | |
092bebab |
35 | if (open(PIPE, "-|")) { |
36 | while(<PIPE>) { |
37 | s/^not //; |
38 | print; |
39 | } |
b6345914 |
40 | close PIPE; # avoid zombies |
092bebab |
41 | } |
42 | else { |
b6345914 |
43 | printf STDOUT "not ok %d - open -|\n", curr_test(); |
44 | next_test(); |
45 | my $tnum = curr_test; |
46 | next_test(); |
47 | exec $Perl, '-le', "print q{not ok $tnum - again}"; |
378cc40b |
48 | } |
ac58e20f |
49 | |
b6345914 |
50 | # This has to be *outside* the fork |
51 | next_test() for 1..2; |
52 | |
713cef20 |
53 | my $raw = "abc\nrst\rxyz\r\nfoo\n"; |
54 | if (open(PIPE, "-|")) { |
55 | $_ = join '', <PIPE>; |
56 | (my $raw1 = $_) =~ s/not ok \d+ - //; |
57 | my @r = map ord, split //, $raw; |
58 | my @r1 = map ord, split //, $raw1; |
59 | if ($raw1 eq $raw) { |
60 | s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s; |
61 | } else { |
62 | s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s; |
63 | } |
64 | print; |
65 | close PIPE; # avoid zombies |
66 | } |
67 | else { |
68 | printf STDOUT "not ok %d - $raw", curr_test(); |
69 | exec $Perl, '-e0'; # Do not run END()... |
70 | } |
71 | |
72 | # This has to be *outside* the fork |
73 | next_test(); |
74 | |
75 | if (open(PIPE, "|-")) { |
76 | printf PIPE "not ok %d - $raw", curr_test(); |
77 | close PIPE; # avoid zombies |
78 | } |
79 | else { |
80 | $_ = join '', <STDIN>; |
81 | (my $raw1 = $_) =~ s/not ok \d+ - //; |
82 | my @r = map ord, split //, $raw; |
83 | my @r1 = map ord, split //, $raw1; |
84 | if ($raw1 eq $raw) { |
85 | s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s; |
86 | } else { |
87 | s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s; |
88 | } |
89 | print; |
90 | exec $Perl, '-e0'; # Do not run END()... |
91 | } |
92 | |
93 | # This has to be *outside* the fork |
94 | next_test(); |
95 | |
b6345914 |
96 | SKIP: { |
97 | skip "fork required", 2 unless $Config{d_fork}; |
98 | |
99 | pipe(READER,WRITER) || die "Can't open pipe"; |
100 | |
101 | if ($pid = fork) { |
102 | close WRITER; |
103 | while(<READER>) { |
104 | s/^not //; |
105 | y/A-Z/a-z/; |
106 | print; |
107 | } |
108 | close READER; # avoid zombies |
109 | } |
110 | else { |
111 | die "Couldn't fork" unless defined $pid; |
112 | close READER; |
113 | printf WRITER "not ok %d - pipe & fork\n", curr_test; |
114 | next_test; |
115 | |
116 | open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; |
117 | close WRITER; |
118 | |
119 | my $tnum = curr_test; |
120 | next_test; |
121 | exec $Perl, '-le', "print q{not ok $tnum - with fh dup }"; |
122 | } |
123 | |
124 | # This has to be done *outside* the fork. |
125 | next_test() for 1..2; |
ac58e20f |
126 | } |
b6345914 |
127 | } |
d6a255e6 |
128 | wait; # Collect from $pid |
ac58e20f |
129 | |
ac58e20f |
130 | pipe(READER,WRITER) || die "Can't open pipe"; |
131 | close READER; |
132 | |
133 | $SIG{'PIPE'} = 'broken_pipe'; |
134 | |
135 | sub broken_pipe { |
1d2dff63 |
136 | $SIG{'PIPE'} = 'IGNORE'; # loop preventer |
b6345914 |
137 | printf "ok %d - SIGPIPE\n", curr_test; |
ac58e20f |
138 | } |
139 | |
b6345914 |
140 | printf WRITER "not ok %d - SIGPIPE\n", curr_test; |
ac58e20f |
141 | close WRITER; |
3d57aefb |
142 | sleep 1; |
b6345914 |
143 | next_test; |
144 | pass(); |
03136e13 |
145 | |
146 | # VMS doesn't like spawning subprocesses that are still connected to |
b6345914 |
147 | # STDOUT. Someone should modify these tests to work with VMS. |
148 | |
149 | SKIP: { |
150 | skip "doesn't like spawning subprocesses that are still connected", 10 |
151 | if $^O eq 'VMS'; |
152 | |
153 | SKIP: { |
154 | # Sfio doesn't report failure when closing a broken pipe |
155 | # that has pending output. Go figure. MachTen doesn't either, |
156 | # but won't write to broken pipes, so nothing's pending at close. |
157 | # BeOS will not write to broken pipes, either. |
158 | # Nor does POSIX-BC. |
159 | skip "Won't report failure on broken pipe", 1 |
160 | if $Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' || |
161 | $^O eq 'posix-bc'; |
162 | |
163 | local $SIG{PIPE} = 'IGNORE'; |
164 | open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!"; |
165 | sleep 5; |
166 | if (print NIL 'foo') { |
167 | # If print was allowed we had better get an error on close |
168 | ok( !close NIL, 'close error on broken pipe' ); |
169 | } |
170 | else { |
171 | ok(close NIL, 'print failed on broken pipe'); |
172 | } |
03136e13 |
173 | } |
03136e13 |
174 | |
b6345914 |
175 | SKIP: { |
176 | skip "Don't work yet", 9 if $^O eq 'vmesa'; |
177 | |
178 | # check that errno gets forced to 0 if the piped program exited |
179 | # non-zero |
180 | open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!"; |
181 | $! = 1; |
182 | ok(!close NIL, 'close failure on non-zero piped exit'); |
183 | is($!, '', ' errno'); |
184 | isnt($?, 0, ' status'); |
185 | |
186 | SKIP: { |
187 | skip "Don't work yet", 6 if $^O eq 'mpeix'; |
188 | |
189 | # check that status for the correct process is collected |
190 | my $zombie; |
191 | unless( $zombie = fork ) { |
192 | $NO_ENDING=1; |
193 | exit 37; |
194 | } |
195 | my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; |
196 | $SIG{ALRM} = sub { return }; |
197 | alarm(1); |
198 | is( close FH, '', 'close failure for... umm, something' ); |
199 | is( $?, 13*256, ' status' ); |
200 | is( $!, '', ' errno'); |
201 | |
202 | my $wait = wait; |
203 | is( $?, 37*256, 'status correct after wait' ); |
204 | is( $wait, $zombie, ' wait pid' ); |
205 | is( $!, '', ' errno'); |
206 | } |
0994c4d0 |
207 | } |
1d3434b8 |
208 | } |
06eaf0bc |
209 | |
210 | # Test new semantics for missing command in piped open |
211 | # 19990114 M-J. Dominus mjd@plover.com |
212 | { local *P; |
3fb41248 |
213 | no warnings 'pipe'; |
b6345914 |
214 | ok( !open(P, "| "), 'missing command in piped open input' ); |
215 | ok( !open(P, " |"), ' output'); |
06eaf0bc |
216 | } |
f2b5be74 |
217 | |
218 | # check that status is unaffected by implicit close |
219 | { |
220 | local(*NIL); |
b6345914 |
221 | open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!"; |
f2b5be74 |
222 | $? = 42; |
223 | # NIL implicitly closed here |
224 | } |
b6345914 |
225 | is($?, 42, 'status unaffected by implicit close'); |
f2b5be74 |
226 | $? = 0; |
faa466a7 |
227 | |
228 | # check that child is reaped if the piped program can't be executed |
38efdb82 |
229 | SKIP: { |
230 | skip "/no_such_process exists", 1 if -e "/no_such_process"; |
faa466a7 |
231 | open NIL, '/no_such_process |'; |
232 | close NIL; |
233 | |
234 | my $child = 0; |
235 | eval { |
236 | local $SIG{ALRM} = sub { die; }; |
237 | alarm 2; |
238 | $child = wait; |
239 | alarm 0; |
240 | }; |
241 | |
b6345914 |
242 | is($child, -1, 'child reaped if piped program cannot be executed'); |
faa466a7 |
243 | } |