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