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
1 #!./perl
2
3 # tests for both real and emulated fork()
4
5 BEGIN {
6     chdir 't' if -d 't';
7     @INC = '../lib';
8     require Config; import Config;
9     unless ($Config{'d_fork'} or $Config{'d_pseudofork'}) {
10         print "1..0 # Skip: no fork\n";
11         exit 0;
12     }
13     $ENV{PERL5LIB} = "../lib";
14 }
15
16 if ($^O eq 'mpeix') {
17     print "1..0 # Skip: fork/status problems on MPE/iX\n";
18     exit 0;
19 }
20
21 $|=1;
22
23 undef $/;
24 @prgs = split "\n########\n", <DATA>;
25 print "1..", scalar @prgs, "\n";
26
27 $tmpfile = "forktmp000";
28 1 while -f ++$tmpfile;
29 END { close TEST; unlink $tmpfile if $tmpfile; }
30
31 $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat'));
32
33 for (@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     }
49     elsif ($^O eq 'NetWare') {
50       $results = `perl -I../lib $switch $tmpfile 2>&1`;
51     }
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;
62     $results =~ s/^\n*Process terminated by SIG\w+\n?//mg
63         if $^O eq 'os2';
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;
76 if ($cid = fork) {
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
85 }
86 else {
87     print "ok 1\n";
88     sleep 10;
89 }
90 EXPECT
91 ok 1
92 ok 2
93 ########
94 $| = 1;
95 if ($cid = fork) {
96     sleep 1;
97     print "not " unless kill 'INT', $cid;
98     print "ok 2\n";
99 }
100 else {
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 }
108 EXPECT
109 ok 1
110 ok 2
111 ########
112 $| = 1;
113 sub 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 }
128 while ($i++ < 3) { do { forkit(); }; }
129 EXPECT
130 iteration 1 start
131 iteration 1 parent
132 iteration 1 child
133 iteration 2 start
134 iteration 2 parent
135 iteration 2 child
136 iteration 2 start
137 iteration 2 parent
138 iteration 2 child
139 iteration 3 start
140 iteration 3 parent
141 iteration 3 child
142 iteration 3 start
143 iteration 3 parent
144 iteration 3 child
145 iteration 3 start
146 iteration 3 parent
147 iteration 3 child
148 iteration 3 start
149 iteration 3 parent
150 iteration 3 child
151 ########
152 $| = 1;
153 fork()
154  ? (print("parent\n"),sleep(1))
155  : (print("child\n"),exit) ;
156 EXPECT
157 parent
158 child
159 ########
160 $| = 1;
161 fork()
162  ? (print("parent\n"),exit)
163  : (print("child\n"),sleep(1)) ;
164 EXPECT
165 parent
166 child
167 ########
168 $| = 1;
169 @a = (1..3);
170 for (@a) {
171     if (fork) {
172         print "parent $_\n";
173         $_ = "[$_]";
174     }
175     else {
176         print "child $_\n";
177         $_ = "-$_-";
178     }
179 }
180 print "@a\n";
181 EXPECT
182 parent 1
183 child 1
184 parent 2
185 child 2
186 parent 2
187 child 2
188 parent 3
189 child 3
190 parent 3
191 child 3
192 parent 3
193 child 3
194 parent 3
195 child 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 ########
205 $| = 1;
206 foreach 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 }
215 while (wait() != -1) { print "waited\n" }
216 EXPECT
217 child 1
218 child 2
219 child 3
220 parent 1
221 parent 2
222 parent 3
223 waited
224 waited
225 waited
226 ########
227 use Config;
228 $| = 1;
229 $\ = "\n";
230 fork()
231  ? print($Config{osname} eq $^O)
232  : print($Config{osname} eq $^O) ;
233 EXPECT
234 1
235 1
236 ########
237 $| = 1;
238 $\ = "\n";
239 fork()
240  ? do { require Config; print($Config::Config{osname} eq $^O); }
241  : do { require Config; print($Config::Config{osname} eq $^O); }
242 EXPECT
243 1
244 1
245 ########
246 $| = 1;
247 use Cwd;
248 $\ = "\n";
249 my $dir;
250 if (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 }
258 else {
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 }
267 EXPECT
268 ok 1 parent
269 ok 1 child
270 ########
271 $| = 1;
272 $\ = "\n";
273 my $getenv;
274 if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
275     $getenv = qq[$^X -e "print \$ENV{TST}"];
276 }
277 else {
278     $getenv = qq[$^X -e 'print \$ENV{TST}'];
279 }
280 $ENV{TST} = 'foo';
281 if (fork) {
282     sleep 1;
283     print "parent before: " . `$getenv`;
284     $ENV{TST} = 'bar';
285     print "parent after: " . `$getenv`;
286 }
287 else {
288     print "child before: " . `$getenv`;
289     $ENV{TST} = 'baz';
290     print "child after: " . `$getenv`;
291 }
292 EXPECT
293 child before: foo
294 child after: baz
295 parent before: foo
296 parent after: bar
297 ########
298 $| = 1;
299 $\ = "\n";
300 if ($pid = fork) {
301     waitpid($pid,0);
302     print "parent got $?"
303 }
304 else {
305     exit(42);
306 }
307 EXPECT
308 parent got 10752
309 ########
310 $| = 1;
311 $\ = "\n";
312 my $echo = 'echo';
313 if ($pid = fork) {
314     waitpid($pid,0);
315     print "parent got $?"
316 }
317 else {
318     exec("$echo foo");
319 }
320 EXPECT
321 foo
322 parent got 0
323 ########
324 if (fork) {
325     die "parent died";
326 }
327 else {
328     die "child died";
329 }
330 EXPECT
331 parent died at - line 2.
332 child died at - line 5.
333 ########
334 if ($pid = fork) {
335     eval { die "parent died" };
336     print $@;
337 }
338 else {
339     eval { die "child died" };
340     print $@;
341 }
342 EXPECT
343 parent died at - line 2.
344 child died at - line 6.
345 ########
346 if (eval q{$pid = fork}) {
347     eval q{ die "parent died" };
348     print $@;
349 }
350 else {
351     eval q{ die "child died" };
352     print $@;
353 }
354 EXPECT
355 parent died at (eval 2) line 1.
356 child died at (eval 2) line 1.
357 ########
358 BEGIN {
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"
368 EXPECT
369 inner
370 ########
371 sub 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
381 if (pipe_to_fork('PARENT','CHILD')) {
382     # parent
383     print PARENT "pipe_to_fork\n";
384     close PARENT;
385 }
386 else {
387     # child
388     while (<CHILD>) { print; }
389     close CHILD;
390     exit;
391 }
392
393 sub 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
403 if (pipe_from_fork('PARENT','CHILD')) {
404     # parent
405     while (<PARENT>) { print; }
406     close PARENT;
407 }
408 else {
409     # child
410     print CHILD "pipe_from_fork\n";
411     close CHILD;
412     exit;
413 }
414 EXPECT
415 pipe_from_fork
416 pipe_to_fork
417 ########
418 $|=1;
419 if ($pid = fork()) {
420     print "forked first kid\n";
421     print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
422 }
423 else {
424     print "first child\n";
425     exit(0);
426 }
427 if ($pid = fork()) {
428     print "forked second kid\n";
429     print "wait() returned ok\n" if wait() == $pid;
430 }
431 else {
432     print "second child\n";
433     exit(0);
434 }
435 EXPECT
436 forked first kid
437 first child
438 waitpid() returned ok
439 forked second kid
440 second child
441 wait() returned ok
442 ########
443 pipe(RDR,WTR) or die $!;
444 my $pid = fork;
445 die "fork: $!" if !defined $pid;
446 if ($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 }
458 EXPECT
459 1
460 ########
461 # [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation
462 sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2);
463 EXPECT
464 1
465 1