Epigraph for 5.29.8
[perl.git] / t / op / fork.t
1 #!./perl
2
3 # tests for both real and emulated fork()
4
5 BEGIN {
6     chdir 't' if -d 't';
7     require './test.pl';
8     set_up_inc('../lib');
9     require Config;
10     skip_all('no fork')
11         unless ($Config::Config{d_fork} or $Config::Config{d_pseudofork});
12     skip_all('no fork')
13         if $^O eq 'MSWin32' && is_miniperl;
14 }
15
16 $|=1;
17
18 run_multiple_progs('', \*DATA);
19
20 my $shell = $ENV{SHELL} || '';
21 SKIP: {
22     skip "This test can only be run under bash or zsh"
23         unless $shell =~ m{/(?:ba|z)sh$};
24     my $probe = qx{
25         $shell -c 'ulimit -u 1 2>/dev/null && echo good'
26     };
27     chomp $probe;
28     skip "Can't set ulimit -u on this system: $probe"
29         unless $probe eq 'good';
30
31     my $out = qx{
32         $shell -c 'ulimit -u 1; exec $^X -e "
33             print((() = fork) == 1 ? q[ok] : q[not ok])
34         "'
35     };
36     # perl #117141
37     skip "fork() didn't fail, maybe you're running as root", 1
38       if $out eq "okok";
39     is($out, "ok", "bash/zsh-only test for 'fork' returning undef on failure");
40 }
41
42 done_testing();
43
44 __END__
45 $| = 1;
46 if ($cid = fork) {
47     sleep 1;
48     if ($result = (kill 9, $cid)) {
49         print "ok 2\n";
50     }
51     else {
52         print "not ok 2 $result\n";
53     }
54     sleep 1 if $^O eq 'MSWin32';        # avoid WinNT race bug
55 }
56 else {
57     print "ok 1\n";
58     sleep 10;
59 }
60 EXPECT
61 OPTION random
62 ok 1
63 ok 2
64 ########
65 $| = 1;
66 if ($cid = fork) {
67     sleep 1;
68     print "not " unless kill 'INT', $cid;
69     print "ok 2\n";
70 }
71 else {
72     # XXX On Windows the default signal handler kills the
73     # XXX whole process, not just the thread (pseudo-process)
74     $SIG{INT} = sub { exit };
75     print "ok 1\n";
76     sleep 5;
77     die;
78 }
79 EXPECT
80 OPTION random
81 ok 1
82 ok 2
83 ########
84 $| = 1;
85 sub forkit {
86     print "iteration $i start\n";
87     my $x = fork;
88     if (defined $x) {
89         if ($x) {
90             print "iteration $i parent\n";
91         }
92         else {
93             print "iteration $i child\n";
94         }
95     }
96     else {
97         print "pid $$ failed to fork\n";
98     }
99 }
100 while ($i++ < 3) { do { forkit(); }; }
101 EXPECT
102 OPTION random
103 iteration 1 start
104 iteration 1 parent
105 iteration 1 child
106 iteration 2 start
107 iteration 2 parent
108 iteration 2 child
109 iteration 2 start
110 iteration 2 parent
111 iteration 2 child
112 iteration 3 start
113 iteration 3 parent
114 iteration 3 child
115 iteration 3 start
116 iteration 3 parent
117 iteration 3 child
118 iteration 3 start
119 iteration 3 parent
120 iteration 3 child
121 iteration 3 start
122 iteration 3 parent
123 iteration 3 child
124 ########
125 $| = 1;
126 fork()
127  ? (print("parent\n"),sleep(1))
128  : (print("child\n"),exit) ;
129 EXPECT
130 OPTION random
131 parent
132 child
133 ########
134 $| = 1;
135 fork()
136  ? (print("parent\n"),exit)
137  : (print("child\n"),sleep(1)) ;
138 EXPECT
139 OPTION random
140 parent
141 child
142 ########
143 $| = 1;
144 @a = (1..3);
145 for (@a) {
146     if (fork) {
147         print "parent $_\n";
148         $_ = "[$_]";
149     }
150     else {
151         print "child $_\n";
152         $_ = "-$_-";
153     }
154 }
155 print "@a\n";
156 EXPECT
157 OPTION random
158 parent 1
159 child 1
160 parent 2
161 child 2
162 parent 2
163 child 2
164 parent 3
165 child 3
166 parent 3
167 child 3
168 parent 3
169 child 3
170 parent 3
171 child 3
172 [1] [2] [3]
173 -1- [2] [3]
174 [1] -2- [3]
175 [1] [2] -3-
176 -1- -2- [3]
177 -1- [2] -3-
178 [1] -2- -3-
179 -1- -2- -3-
180 ########
181 $| = 1;
182 foreach my $c (1,2,3) {
183     if (fork) {
184         print "parent $c\n";
185     }
186     else {
187         print "child $c\n";
188         exit;
189     }
190 }
191 while (wait() != -1) { print "waited\n" }
192 EXPECT
193 OPTION random
194 child 1
195 child 2
196 child 3
197 parent 1
198 parent 2
199 parent 3
200 waited
201 waited
202 waited
203 ########
204 use Config;
205 $| = 1;
206 $\ = "\n";
207 fork()
208  ? print($Config{osname} eq $^O)
209  : print($Config{osname} eq $^O) ;
210 EXPECT
211 OPTION random
212 1
213 1
214 ########
215 $| = 1;
216 $\ = "\n";
217 fork()
218  ? do { require Config; print($Config::Config{osname} eq $^O); }
219  : do { require Config; print($Config::Config{osname} eq $^O); }
220 EXPECT
221 OPTION random
222 1
223 1
224 ########
225 $| = 1;
226 use Cwd;
227 my $cwd = cwd(); # Make sure we load Win32.pm while "../lib" still works.
228 $\ = "\n";
229 my $dir;
230 if (fork) {
231     $dir = "f$$.tst";
232     mkdir $dir, 0755;
233     chdir $dir;
234     print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
235     chdir "..";
236     rmdir $dir;
237 }
238 else {
239     sleep 2;
240     $dir = "f$$.tst";
241     mkdir $dir, 0755;
242     chdir $dir;
243     print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
244     chdir "..";
245     rmdir $dir;
246 }
247 EXPECT
248 OPTION random
249 ok 1 parent
250 ok 1 child
251 ########
252 $| = 1;
253 $\ = "\n";
254 my $getenv;
255 if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
256     $getenv = qq[$^X -e "print \$ENV{TST}"];
257 }
258 else {
259     $getenv = qq[$^X -e 'print \$ENV{TST}'];
260 }
261 $ENV{TST} = 'foo';
262 if (fork) {
263     sleep 1;
264     print "parent before: " . `$getenv`;
265     $ENV{TST} = 'bar';
266     print "parent after: " . `$getenv`;
267 }
268 else {
269     print "child before: " . `$getenv`;
270     $ENV{TST} = 'baz';
271     print "child after: " . `$getenv`;
272 }
273 EXPECT
274 OPTION random
275 child before: foo
276 child after: baz
277 parent before: foo
278 parent after: bar
279 ########
280 $| = 1;
281 $\ = "\n";
282 if ($pid = fork) {
283     waitpid($pid,0);
284     print "parent got $?"
285 }
286 else {
287     exit(42);
288 }
289 EXPECT
290 OPTION random
291 parent got 10752
292 ########
293 $| = 1;
294 $\ = "\n";
295 my $echo = 'echo';
296 if ($^O =~ /android/) {
297     $echo = q{sh -c 'echo $@' -- };
298 }
299 if ($pid = fork) {
300     waitpid($pid,0);
301     print "parent got $?"
302 }
303 else {
304     exec("$echo foo");
305 }
306 EXPECT
307 OPTION random
308 foo
309 parent got 0
310 ########
311 if (fork) {
312     die "parent died";
313 }
314 else {
315     die "child died";
316 }
317 EXPECT
318 OPTION random
319 parent died at - line 2.
320 child died at - line 5.
321 ########
322 if ($pid = fork) {
323     eval { die "parent died" };
324     print $@;
325 }
326 else {
327     eval { die "child died" };
328     print $@;
329 }
330 EXPECT
331 OPTION random
332 parent died at - line 2.
333 child died at - line 6.
334 ########
335 if (eval q{$pid = fork}) {
336     eval q{ die "parent died" };
337     print $@;
338 }
339 else {
340     eval q{ die "child died" };
341     print $@;
342 }
343 EXPECT
344 OPTION random
345 parent died at (eval 2) line 1.
346 child died at (eval 2) line 1.
347 ########
348 BEGIN {
349     $| = 1;
350     fork and exit;
351     print "inner\n";
352 }
353 # XXX In emulated fork(), the child will not execute anything after
354 # the BEGIN block, due to difficulties in recreating the parse stacks
355 # and restarting yyparse() midstream in the child.  This can potentially
356 # be overcome by treating what's after the BEGIN{} as a brand new parse.
357 #print "outer\n"
358 EXPECT
359 OPTION random
360 inner
361 ########
362 sub pipe_to_fork ($$) {
363     my $parent = shift;
364     my $child = shift;
365     pipe($child, $parent) or die;
366     my $pid = fork();
367     die "fork() failed: $!" unless defined $pid;
368     close($pid ? $child : $parent);
369     $pid;
370 }
371
372 if (pipe_to_fork('PARENT','CHILD')) {
373     # parent
374     print PARENT "pipe_to_fork\n";
375     close PARENT;
376 }
377 else {
378     # child
379     while (<CHILD>) { print; }
380     close CHILD;
381     exit;
382 }
383
384 sub pipe_from_fork ($$) {
385     my $parent = shift;
386     my $child = shift;
387     pipe($parent, $child) or die;
388     my $pid = fork();
389     die "fork() failed: $!" unless defined $pid;
390     close($pid ? $child : $parent);
391     $pid;
392 }
393
394 if (pipe_from_fork('PARENT','CHILD')) {
395     # parent
396     while (<PARENT>) { print; }
397     close PARENT;
398 }
399 else {
400     # child
401     print CHILD "pipe_from_fork\n";
402     close CHILD;
403     exit;
404 }
405 EXPECT
406 OPTION random
407 pipe_from_fork
408 pipe_to_fork
409 ########
410 $|=1;
411 if ($pid = fork()) {
412     print "forked first kid\n";
413     print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
414 }
415 else {
416     print "first child\n";
417     exit(0);
418 }
419 if ($pid = fork()) {
420     print "forked second kid\n";
421     print "wait() returned ok\n" if wait() == $pid;
422 }
423 else {
424     print "second child\n";
425     exit(0);
426 }
427 EXPECT
428 OPTION random
429 forked first kid
430 first child
431 waitpid() returned ok
432 forked second kid
433 second child
434 wait() returned ok
435 ########
436 pipe(RDR,WTR) or die $!;
437 my $pid = fork;
438 die "fork: $!" if !defined $pid;
439 if ($pid == 0) {
440     close RDR;
441     print WTR "STRING_FROM_CHILD\n";
442     close WTR;
443 } else {
444     close WTR;
445     chomp(my $string_from_child  = <RDR>);
446     close RDR;
447     print $string_from_child eq "STRING_FROM_CHILD", "\n";
448 }
449 EXPECT
450 OPTION random
451 1
452 ########
453 # [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation
454 sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2);
455 EXPECT
456 OPTION random
457 1
458 1
459 ########
460 # [perl #72604] @DB::args stops working across Win32 fork
461 $|=1;
462 sub f {
463     if ($pid = fork()) {
464         print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
465     }
466     else {
467         package DB;
468         my @c = caller(0);
469         print "child: called as [$c[3](", join(',',@DB::args), ")]\n";
470         exit(0);
471     }
472 }
473 f("foo", "bar");
474 EXPECT
475 OPTION random
476 child: called as [main::f(foo,bar)]
477 waitpid() returned ok
478 ########
479 # Windows 2000: https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
480 system $^X,  "-e", "if (\$pid=fork){sleep 1;kill(9, \$pid)} else {sleep 5}";
481 print $?>>8, "\n";
482 EXPECT
483 0
484 ########
485 # Windows 7: https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
486 system $^X,  "-e", "if (\$pid=fork){kill(9, \$pid)} else {sleep 5}";
487 print $?>>8, "\n";
488 EXPECT
489 0
490 ########
491 # Windows fork() emulation: can we still waitpid() after signalling SIGTERM?
492 $|=1;
493 if (my $pid = fork) {
494     sleep 1;
495     print "1\n";
496     kill 'TERM', $pid;
497     waitpid($pid, 0);
498     print "4\n";
499 }
500 else {
501     $SIG{TERM} = sub { print "2\n" };
502     sleep 10;
503     print "3\n";
504 }
505 EXPECT
506 1
507 2
508 3
509 4
510 ########
511 # this used to SEGV. RT # 121721
512 $|=1;
513 &main;
514 sub main {
515     if (my $pid = fork) {
516         waitpid($pid, 0);
517     }
518     else {
519         print "foo\n";
520     }
521 }
522 EXPECT
523 foo
524 ########
525 # ${^GLOBAL_PHASE} at the end of a pseudo-fork
526 if (my $pid = fork) {
527     waitpid $pid, 0;
528 } else {
529     eval 'END { print "${^GLOBAL_PHASE}\n" }';
530     exit;
531 }
532 EXPECT
533 END