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