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