This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Migrate the test running logic from t/lib/common.pl to t/test/pl
[perl5.git] / t / op / fork.t
CommitLineData
8d063cd8
LW
1#!./perl
2
7766f137 3# tests for both real and emulated fork()
8d063cd8 4
774d564b 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 11 exit 0;
12 }
7766f137 13 $ENV{PERL5LIB} = "../lib";
1c25d394 14 require './test.pl';
774d564b 15}
16
0994c4d0
JH
17if ($^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
24undef $/;
25@prgs = split "\n########\n", <DATA>;
26print "1..", scalar @prgs, "\n";
27
1c25d394
NC
28$tmpfile = tempfile();
29END { close TEST }
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+$//;
1c25d394
NC
57 $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g;
58 $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g;
7766f137
GS
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;
cf2f24a4 248my $cwd = cwd(); # Make sure we load Win32.pm while "../lib" still works.
7766f137
GS
249$\ = "\n";
250my $dir;
251if (fork) {
252 $dir = "f$$.tst";
253 mkdir $dir, 0755;
254 chdir $dir;
255 print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
256 chdir "..";
257 rmdir $dir;
258}
259else {
260 sleep 2;
261 $dir = "f$$.tst";
262 mkdir $dir, 0755;
263 chdir $dir;
264 print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
265 chdir "..";
266 rmdir $dir;
267}
268EXPECT
269ok 1 parent
270ok 1 child
271########
272$| = 1;
273$\ = "\n";
274my $getenv;
2986a63f 275if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
7766f137
GS
276 $getenv = qq[$^X -e "print \$ENV{TST}"];
277}
278else {
279 $getenv = qq[$^X -e 'print \$ENV{TST}'];
280}
35424068 281$ENV{TST} = 'foo';
7766f137
GS
282if (fork) {
283 sleep 1;
35424068
GS
284 print "parent before: " . `$getenv`;
285 $ENV{TST} = 'bar';
286 print "parent after: " . `$getenv`;
7766f137
GS
287}
288else {
35424068
GS
289 print "child before: " . `$getenv`;
290 $ENV{TST} = 'baz';
291 print "child after: " . `$getenv`;
7766f137
GS
292}
293EXPECT
35424068
GS
294child before: foo
295child after: baz
296parent before: foo
297parent after: bar
7766f137
GS
298########
299$| = 1;
300$\ = "\n";
301if ($pid = fork) {
302 waitpid($pid,0);
303 print "parent got $?"
304}
305else {
306 exit(42);
307}
308EXPECT
309parent got 10752
310########
311$| = 1;
312$\ = "\n";
313my $echo = 'echo';
314if ($pid = fork) {
315 waitpid($pid,0);
316 print "parent got $?"
317}
318else {
319 exec("$echo foo");
320}
321EXPECT
322foo
323parent got 0
324########
325if (fork) {
326 die "parent died";
327}
328else {
329 die "child died";
330}
331EXPECT
332parent died at - line 2.
333child died at - line 5.
334########
335if ($pid = fork) {
336 eval { die "parent died" };
337 print $@;
338}
339else {
340 eval { die "child died" };
341 print $@;
342}
343EXPECT
344parent died at - line 2.
345child died at - line 6.
346########
347if (eval q{$pid = fork}) {
348 eval q{ die "parent died" };
349 print $@;
350}
351else {
352 eval q{ die "child died" };
353 print $@;
354}
355EXPECT
356parent died at (eval 2) line 1.
357child died at (eval 2) line 1.
358########
359BEGIN {
360 $| = 1;
361 fork and exit;
362 print "inner\n";
363}
364# XXX In emulated fork(), the child will not execute anything after
365# the BEGIN block, due to difficulties in recreating the parse stacks
366# and restarting yyparse() midstream in the child. This can potentially
367# be overcome by treating what's after the BEGIN{} as a brand new parse.
368#print "outer\n"
369EXPECT
370inner
030866aa
GS
371########
372sub pipe_to_fork ($$) {
373 my $parent = shift;
374 my $child = shift;
375 pipe($child, $parent) or die;
376 my $pid = fork();
377 die "fork() failed: $!" unless defined $pid;
378 close($pid ? $child : $parent);
379 $pid;
380}
381
382if (pipe_to_fork('PARENT','CHILD')) {
383 # parent
384 print PARENT "pipe_to_fork\n";
385 close PARENT;
386}
387else {
388 # child
389 while (<CHILD>) { print; }
390 close CHILD;
391 exit;
392}
393
394sub pipe_from_fork ($$) {
395 my $parent = shift;
396 my $child = shift;
397 pipe($parent, $child) or die;
398 my $pid = fork();
399 die "fork() failed: $!" unless defined $pid;
400 close($pid ? $child : $parent);
401 $pid;
402}
403
404if (pipe_from_fork('PARENT','CHILD')) {
405 # parent
406 while (<PARENT>) { print; }
407 close PARENT;
408}
409else {
410 # child
411 print CHILD "pipe_from_fork\n";
412 close CHILD;
413 exit;
414}
415EXPECT
416pipe_from_fork
417pipe_to_fork
68a29c53 418########
10d51319 419$|=1;
68a29c53
GS
420if ($pid = fork()) {
421 print "forked first kid\n";
422 print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
423}
424else {
425 print "first child\n";
426 exit(0);
427}
428if ($pid = fork()) {
429 print "forked second kid\n";
430 print "wait() returned ok\n" if wait() == $pid;
431}
432else {
433 print "second child\n";
434 exit(0);
435}
436EXPECT
437forked first kid
438first child
439waitpid() returned ok
440forked second kid
441second child
442wait() returned ok
a0bd7037
SR
443########
444pipe(RDR,WTR) or die $!;
445my $pid = fork;
446die "fork: $!" if !defined $pid;
447if ($pid == 0) {
a0bd7037 448 close RDR;
5bf4f5b3 449 print WTR "STRING_FROM_CHILD\n";
a0bd7037
SR
450 close WTR;
451} else {
a0bd7037 452 close WTR;
5bf4f5b3 453 chomp(my $string_from_child = <RDR>);
a0bd7037 454 close RDR;
5bf4f5b3 455 print $string_from_child eq "STRING_FROM_CHILD", "\n";
a0bd7037
SR
456}
457EXPECT
4581
d8d97e70
DM
459########
460# [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation
461sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2);
462EXPECT
4631
4641
a1f97a07
DM
465########
466# [perl #72604] @DB::args stops working across Win32 fork
467$|=1;
468sub f {
469 if ($pid = fork()) {
470 print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
471 }
472 else {
473 package DB;
474 my @c = caller(0);
475 print "child: called as [$c[3](", join(',',@DB::args), ")]\n";
476 exit(0);
477 }
478}
479f("foo", "bar");
480EXPECT
481child: called as [main::f(foo,bar)]
482waitpid() returned ok