Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
7766f137 | 3 | # tests for both real and emulated fork() |
8d063cd8 | 4 | |
774d564b | 5 | BEGIN { |
6 | chdir 't' if -d 't'; | |
20822f61 | 7 | @INC = '../lib'; |
774d564b | 8 | require Config; import Config; |
2b09c5a8 | 9 | unless ($Config{'d_fork'} or $Config{'d_pseudofork'}) { |
45c0de28 | 10 | print "1..0 # Skip: no fork\n"; |
774d564b | 11 | exit 0; |
12 | } | |
7766f137 | 13 | $ENV{PERL5LIB} = "../lib"; |
1c25d394 | 14 | require './test.pl'; |
774d564b | 15 | } |
16 | ||
0994c4d0 JH |
17 | if ($^O eq 'mpeix') { |
18 | print "1..0 # Skip: fork/status problems on MPE/iX\n"; | |
19 | exit 0; | |
20 | } | |
21 | ||
7766f137 GS |
22 | $|=1; |
23 | ||
5f7e0818 | 24 | run_multiple_progs('', \*DATA); |
7766f137 | 25 | |
5f7e0818 | 26 | done_testing(); |
7766f137 GS |
27 | |
28 | __END__ | |
29 | $| = 1; | |
8d063cd8 | 30 | if ($cid = fork) { |
7766f137 GS |
31 | sleep 1; |
32 | if ($result = (kill 9, $cid)) { | |
33 | print "ok 2\n"; | |
34 | } | |
35 | else { | |
36 | print "not ok 2 $result\n"; | |
37 | } | |
38 | sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug | |
8d063cd8 LW |
39 | } |
40 | else { | |
8d063cd8 LW |
41 | print "ok 1\n"; |
42 | sleep 10; | |
43 | } | |
7766f137 | 44 | EXPECT |
5f7e0818 | 45 | OPTION random |
7766f137 GS |
46 | ok 1 |
47 | ok 2 | |
48 | ######## | |
49 | $| = 1; | |
aeecf691 JD |
50 | if ($cid = fork) { |
51 | sleep 1; | |
52 | print "not " unless kill 'INT', $cid; | |
53 | print "ok 2\n"; | |
54 | } | |
55 | else { | |
56 | # XXX On Windows the default signal handler kills the | |
57 | # XXX whole process, not just the thread (pseudo-process) | |
58 | $SIG{INT} = sub { exit }; | |
59 | print "ok 1\n"; | |
60 | sleep 5; | |
61 | die; | |
62 | } | |
63 | EXPECT | |
5f7e0818 | 64 | OPTION random |
aeecf691 JD |
65 | ok 1 |
66 | ok 2 | |
67 | ######## | |
68 | $| = 1; | |
7766f137 GS |
69 | sub forkit { |
70 | print "iteration $i start\n"; | |
71 | my $x = fork; | |
72 | if (defined $x) { | |
73 | if ($x) { | |
74 | print "iteration $i parent\n"; | |
75 | } | |
76 | else { | |
77 | print "iteration $i child\n"; | |
78 | } | |
79 | } | |
80 | else { | |
81 | print "pid $$ failed to fork\n"; | |
82 | } | |
83 | } | |
84 | while ($i++ < 3) { do { forkit(); }; } | |
85 | EXPECT | |
5f7e0818 | 86 | OPTION random |
7766f137 GS |
87 | iteration 1 start |
88 | iteration 1 parent | |
89 | iteration 1 child | |
90 | iteration 2 start | |
91 | iteration 2 parent | |
92 | iteration 2 child | |
93 | iteration 2 start | |
94 | iteration 2 parent | |
95 | iteration 2 child | |
96 | iteration 3 start | |
97 | iteration 3 parent | |
98 | iteration 3 child | |
99 | iteration 3 start | |
100 | iteration 3 parent | |
101 | iteration 3 child | |
102 | iteration 3 start | |
103 | iteration 3 parent | |
104 | iteration 3 child | |
105 | iteration 3 start | |
106 | iteration 3 parent | |
107 | iteration 3 child | |
108 | ######## | |
109 | $| = 1; | |
110 | fork() | |
111 | ? (print("parent\n"),sleep(1)) | |
112 | : (print("child\n"),exit) ; | |
113 | EXPECT | |
5f7e0818 | 114 | OPTION random |
7766f137 GS |
115 | parent |
116 | child | |
117 | ######## | |
118 | $| = 1; | |
119 | fork() | |
120 | ? (print("parent\n"),exit) | |
121 | : (print("child\n"),sleep(1)) ; | |
122 | EXPECT | |
5f7e0818 | 123 | OPTION random |
7766f137 GS |
124 | parent |
125 | child | |
126 | ######## | |
127 | $| = 1; | |
128 | @a = (1..3); | |
129 | for (@a) { | |
130 | if (fork) { | |
131 | print "parent $_\n"; | |
132 | $_ = "[$_]"; | |
133 | } | |
134 | else { | |
135 | print "child $_\n"; | |
136 | $_ = "-$_-"; | |
137 | } | |
138 | } | |
139 | print "@a\n"; | |
140 | EXPECT | |
5f7e0818 | 141 | OPTION random |
7766f137 GS |
142 | parent 1 |
143 | child 1 | |
144 | parent 2 | |
145 | child 2 | |
146 | parent 2 | |
147 | child 2 | |
148 | parent 3 | |
149 | child 3 | |
150 | parent 3 | |
151 | child 3 | |
152 | parent 3 | |
153 | child 3 | |
154 | parent 3 | |
155 | child 3 | |
156 | [1] [2] [3] | |
157 | -1- [2] [3] | |
158 | [1] -2- [3] | |
159 | [1] [2] -3- | |
160 | -1- -2- [3] | |
161 | -1- [2] -3- | |
162 | [1] -2- -3- | |
163 | -1- -2- -3- | |
164 | ######## | |
c3564e5c GS |
165 | $| = 1; |
166 | foreach my $c (1,2,3) { | |
167 | if (fork) { | |
168 | print "parent $c\n"; | |
169 | } | |
170 | else { | |
171 | print "child $c\n"; | |
172 | exit; | |
173 | } | |
174 | } | |
175 | while (wait() != -1) { print "waited\n" } | |
176 | EXPECT | |
5f7e0818 | 177 | OPTION random |
c3564e5c GS |
178 | child 1 |
179 | child 2 | |
180 | child 3 | |
181 | parent 1 | |
182 | parent 2 | |
183 | parent 3 | |
184 | waited | |
185 | waited | |
186 | waited | |
187 | ######## | |
7766f137 GS |
188 | use Config; |
189 | $| = 1; | |
190 | $\ = "\n"; | |
191 | fork() | |
192 | ? print($Config{osname} eq $^O) | |
193 | : print($Config{osname} eq $^O) ; | |
194 | EXPECT | |
5f7e0818 | 195 | OPTION random |
7766f137 GS |
196 | 1 |
197 | 1 | |
198 | ######## | |
199 | $| = 1; | |
200 | $\ = "\n"; | |
201 | fork() | |
202 | ? do { require Config; print($Config::Config{osname} eq $^O); } | |
203 | : do { require Config; print($Config::Config{osname} eq $^O); } | |
204 | EXPECT | |
5f7e0818 | 205 | OPTION random |
7766f137 GS |
206 | 1 |
207 | 1 | |
208 | ######## | |
209 | $| = 1; | |
210 | use Cwd; | |
cf2f24a4 | 211 | my $cwd = cwd(); # Make sure we load Win32.pm while "../lib" still works. |
7766f137 GS |
212 | $\ = "\n"; |
213 | my $dir; | |
214 | if (fork) { | |
215 | $dir = "f$$.tst"; | |
216 | mkdir $dir, 0755; | |
217 | chdir $dir; | |
218 | print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; | |
219 | chdir ".."; | |
220 | rmdir $dir; | |
221 | } | |
222 | else { | |
223 | sleep 2; | |
224 | $dir = "f$$.tst"; | |
225 | mkdir $dir, 0755; | |
226 | chdir $dir; | |
227 | print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; | |
228 | chdir ".."; | |
229 | rmdir $dir; | |
230 | } | |
231 | EXPECT | |
5f7e0818 | 232 | OPTION random |
7766f137 GS |
233 | ok 1 parent |
234 | ok 1 child | |
235 | ######## | |
236 | $| = 1; | |
237 | $\ = "\n"; | |
238 | my $getenv; | |
2986a63f | 239 | if ($^O eq 'MSWin32' || $^O eq 'NetWare') { |
7766f137 GS |
240 | $getenv = qq[$^X -e "print \$ENV{TST}"]; |
241 | } | |
242 | else { | |
243 | $getenv = qq[$^X -e 'print \$ENV{TST}']; | |
244 | } | |
35424068 | 245 | $ENV{TST} = 'foo'; |
7766f137 GS |
246 | if (fork) { |
247 | sleep 1; | |
35424068 GS |
248 | print "parent before: " . `$getenv`; |
249 | $ENV{TST} = 'bar'; | |
250 | print "parent after: " . `$getenv`; | |
7766f137 GS |
251 | } |
252 | else { | |
35424068 GS |
253 | print "child before: " . `$getenv`; |
254 | $ENV{TST} = 'baz'; | |
255 | print "child after: " . `$getenv`; | |
7766f137 GS |
256 | } |
257 | EXPECT | |
5f7e0818 | 258 | OPTION random |
35424068 GS |
259 | child before: foo |
260 | child after: baz | |
261 | parent before: foo | |
262 | parent after: bar | |
7766f137 GS |
263 | ######## |
264 | $| = 1; | |
265 | $\ = "\n"; | |
266 | if ($pid = fork) { | |
267 | waitpid($pid,0); | |
268 | print "parent got $?" | |
269 | } | |
270 | else { | |
271 | exit(42); | |
272 | } | |
273 | EXPECT | |
5f7e0818 | 274 | OPTION random |
7766f137 GS |
275 | parent got 10752 |
276 | ######## | |
277 | $| = 1; | |
278 | $\ = "\n"; | |
279 | my $echo = 'echo'; | |
280 | if ($pid = fork) { | |
281 | waitpid($pid,0); | |
282 | print "parent got $?" | |
283 | } | |
284 | else { | |
285 | exec("$echo foo"); | |
286 | } | |
287 | EXPECT | |
5f7e0818 | 288 | OPTION random |
7766f137 GS |
289 | foo |
290 | parent got 0 | |
291 | ######## | |
292 | if (fork) { | |
293 | die "parent died"; | |
294 | } | |
295 | else { | |
296 | die "child died"; | |
297 | } | |
298 | EXPECT | |
5f7e0818 | 299 | OPTION random |
7766f137 GS |
300 | parent died at - line 2. |
301 | child died at - line 5. | |
302 | ######## | |
303 | if ($pid = fork) { | |
304 | eval { die "parent died" }; | |
305 | print $@; | |
306 | } | |
307 | else { | |
308 | eval { die "child died" }; | |
309 | print $@; | |
310 | } | |
311 | EXPECT | |
5f7e0818 | 312 | OPTION random |
7766f137 GS |
313 | parent died at - line 2. |
314 | child died at - line 6. | |
315 | ######## | |
316 | if (eval q{$pid = fork}) { | |
317 | eval q{ die "parent died" }; | |
318 | print $@; | |
319 | } | |
320 | else { | |
321 | eval q{ die "child died" }; | |
322 | print $@; | |
323 | } | |
324 | EXPECT | |
5f7e0818 | 325 | OPTION random |
7766f137 GS |
326 | parent died at (eval 2) line 1. |
327 | child died at (eval 2) line 1. | |
328 | ######## | |
329 | BEGIN { | |
330 | $| = 1; | |
331 | fork and exit; | |
332 | print "inner\n"; | |
333 | } | |
334 | # XXX In emulated fork(), the child will not execute anything after | |
335 | # the BEGIN block, due to difficulties in recreating the parse stacks | |
336 | # and restarting yyparse() midstream in the child. This can potentially | |
337 | # be overcome by treating what's after the BEGIN{} as a brand new parse. | |
338 | #print "outer\n" | |
339 | EXPECT | |
5f7e0818 | 340 | OPTION random |
7766f137 | 341 | inner |
030866aa GS |
342 | ######## |
343 | sub pipe_to_fork ($$) { | |
344 | my $parent = shift; | |
345 | my $child = shift; | |
346 | pipe($child, $parent) or die; | |
347 | my $pid = fork(); | |
348 | die "fork() failed: $!" unless defined $pid; | |
349 | close($pid ? $child : $parent); | |
350 | $pid; | |
351 | } | |
352 | ||
353 | if (pipe_to_fork('PARENT','CHILD')) { | |
354 | # parent | |
355 | print PARENT "pipe_to_fork\n"; | |
356 | close PARENT; | |
357 | } | |
358 | else { | |
359 | # child | |
360 | while (<CHILD>) { print; } | |
361 | close CHILD; | |
362 | exit; | |
363 | } | |
364 | ||
365 | sub pipe_from_fork ($$) { | |
366 | my $parent = shift; | |
367 | my $child = shift; | |
368 | pipe($parent, $child) or die; | |
369 | my $pid = fork(); | |
370 | die "fork() failed: $!" unless defined $pid; | |
371 | close($pid ? $child : $parent); | |
372 | $pid; | |
373 | } | |
374 | ||
375 | if (pipe_from_fork('PARENT','CHILD')) { | |
376 | # parent | |
377 | while (<PARENT>) { print; } | |
378 | close PARENT; | |
379 | } | |
380 | else { | |
381 | # child | |
382 | print CHILD "pipe_from_fork\n"; | |
383 | close CHILD; | |
384 | exit; | |
385 | } | |
386 | EXPECT | |
5f7e0818 | 387 | OPTION random |
030866aa GS |
388 | pipe_from_fork |
389 | pipe_to_fork | |
68a29c53 | 390 | ######## |
10d51319 | 391 | $|=1; |
68a29c53 GS |
392 | if ($pid = fork()) { |
393 | print "forked first kid\n"; | |
394 | print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; | |
395 | } | |
396 | else { | |
397 | print "first child\n"; | |
398 | exit(0); | |
399 | } | |
400 | if ($pid = fork()) { | |
401 | print "forked second kid\n"; | |
402 | print "wait() returned ok\n" if wait() == $pid; | |
403 | } | |
404 | else { | |
405 | print "second child\n"; | |
406 | exit(0); | |
407 | } | |
408 | EXPECT | |
5f7e0818 | 409 | OPTION random |
68a29c53 GS |
410 | forked first kid |
411 | first child | |
412 | waitpid() returned ok | |
413 | forked second kid | |
414 | second child | |
415 | wait() returned ok | |
a0bd7037 SR |
416 | ######## |
417 | pipe(RDR,WTR) or die $!; | |
418 | my $pid = fork; | |
419 | die "fork: $!" if !defined $pid; | |
420 | if ($pid == 0) { | |
a0bd7037 | 421 | close RDR; |
5bf4f5b3 | 422 | print WTR "STRING_FROM_CHILD\n"; |
a0bd7037 SR |
423 | close WTR; |
424 | } else { | |
a0bd7037 | 425 | close WTR; |
5bf4f5b3 | 426 | chomp(my $string_from_child = <RDR>); |
a0bd7037 | 427 | close RDR; |
5bf4f5b3 | 428 | print $string_from_child eq "STRING_FROM_CHILD", "\n"; |
a0bd7037 SR |
429 | } |
430 | EXPECT | |
5f7e0818 | 431 | OPTION random |
a0bd7037 | 432 | 1 |
d8d97e70 DM |
433 | ######## |
434 | # [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation | |
435 | sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2); | |
436 | EXPECT | |
5f7e0818 | 437 | OPTION random |
d8d97e70 DM |
438 | 1 |
439 | 1 | |
a1f97a07 DM |
440 | ######## |
441 | # [perl #72604] @DB::args stops working across Win32 fork | |
442 | $|=1; | |
443 | sub f { | |
444 | if ($pid = fork()) { | |
445 | print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; | |
446 | } | |
447 | else { | |
448 | package DB; | |
449 | my @c = caller(0); | |
450 | print "child: called as [$c[3](", join(',',@DB::args), ")]\n"; | |
451 | exit(0); | |
452 | } | |
453 | } | |
454 | f("foo", "bar"); | |
455 | EXPECT | |
5f7e0818 | 456 | OPTION random |
a1f97a07 DM |
457 | child: called as [main::f(foo,bar)] |
458 | waitpid() returned ok |