Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.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 my $cwd = cwd(); # Make sure we load Win32.pm while "../lib" still works.
249 $\ = "\n";
250 my $dir;
251 if (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 }
259 else {
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 }
268 EXPECT
269 ok 1 parent
270 ok 1 child
271 ########
272 $| = 1;
273 $\ = "\n";
274 my $getenv;
275 if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
276     $getenv = qq[$^X -e "print \$ENV{TST}"];
277 }
278 else {
279     $getenv = qq[$^X -e 'print \$ENV{TST}'];
280 }
281 $ENV{TST} = 'foo';
282 if (fork) {
283     sleep 1;
284     print "parent before: " . `$getenv`;
285     $ENV{TST} = 'bar';
286     print "parent after: " . `$getenv`;
287 }
288 else {
289     print "child before: " . `$getenv`;
290     $ENV{TST} = 'baz';
291     print "child after: " . `$getenv`;
292 }
293 EXPECT
294 child before: foo
295 child after: baz
296 parent before: foo
297 parent after: bar
298 ########
299 $| = 1;
300 $\ = "\n";
301 if ($pid = fork) {
302     waitpid($pid,0);
303     print "parent got $?"
304 }
305 else {
306     exit(42);
307 }
308 EXPECT
309 parent got 10752
310 ########
311 $| = 1;
312 $\ = "\n";
313 my $echo = 'echo';
314 if ($pid = fork) {
315     waitpid($pid,0);
316     print "parent got $?"
317 }
318 else {
319     exec("$echo foo");
320 }
321 EXPECT
322 foo
323 parent got 0
324 ########
325 if (fork) {
326     die "parent died";
327 }
328 else {
329     die "child died";
330 }
331 EXPECT
332 parent died at - line 2.
333 child died at - line 5.
334 ########
335 if ($pid = fork) {
336     eval { die "parent died" };
337     print $@;
338 }
339 else {
340     eval { die "child died" };
341     print $@;
342 }
343 EXPECT
344 parent died at - line 2.
345 child died at - line 6.
346 ########
347 if (eval q{$pid = fork}) {
348     eval q{ die "parent died" };
349     print $@;
350 }
351 else {
352     eval q{ die "child died" };
353     print $@;
354 }
355 EXPECT
356 parent died at (eval 2) line 1.
357 child died at (eval 2) line 1.
358 ########
359 BEGIN {
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"
369 EXPECT
370 inner
371 ########
372 sub 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
382 if (pipe_to_fork('PARENT','CHILD')) {
383     # parent
384     print PARENT "pipe_to_fork\n";
385     close PARENT;
386 }
387 else {
388     # child
389     while (<CHILD>) { print; }
390     close CHILD;
391     exit;
392 }
393
394 sub 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
404 if (pipe_from_fork('PARENT','CHILD')) {
405     # parent
406     while (<PARENT>) { print; }
407     close PARENT;
408 }
409 else {
410     # child
411     print CHILD "pipe_from_fork\n";
412     close CHILD;
413     exit;
414 }
415 EXPECT
416 pipe_from_fork
417 pipe_to_fork
418 ########
419 $|=1;
420 if ($pid = fork()) {
421     print "forked first kid\n";
422     print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
423 }
424 else {
425     print "first child\n";
426     exit(0);
427 }
428 if ($pid = fork()) {
429     print "forked second kid\n";
430     print "wait() returned ok\n" if wait() == $pid;
431 }
432 else {
433     print "second child\n";
434     exit(0);
435 }
436 EXPECT
437 forked first kid
438 first child
439 waitpid() returned ok
440 forked second kid
441 second child
442 wait() returned ok
443 ########
444 pipe(RDR,WTR) or die $!;
445 my $pid = fork;
446 die "fork: $!" if !defined $pid;
447 if ($pid == 0) {
448     my $rand_child = rand;
449     close RDR;
450     print WTR $rand_child, "\n";
451     close WTR;
452 } else {
453     my $rand_parent = rand;
454     close WTR;
455     chomp(my $rand_child  = <RDR>);
456     close RDR;
457     print $rand_child ne $rand_parent, "\n";
458 }
459 EXPECT
460 1
461 ########
462 # [perl #39145] Perl_dounwind() crashing with Win32's fork() emulation
463 sub { @_ = 3; fork ? die "1\n" : die "1\n" }->(2);
464 EXPECT
465 1
466 1