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