Suppress a few compilation warnings in pp_hot.c.
[p5sagit/p5-mst-13.2.git] / t / op / fork.t
CommitLineData
8d063cd8 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;
dfdd1393 9 unless ($Config{'d_fork'}
2986a63f 10 or (($^O eq 'MSWin32' || $^O eq 'NetWare') and $Config{useithreads}
5f1a76d0 11 and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
12# and !defined $Config{'useperlio'}
13 ))
dfdd1393 14 {
45c0de28 15 print "1..0 # Skip: no fork\n";
774d564b 16 exit 0;
17 }
7766f137 18 $ENV{PERL5LIB} = "../lib";
774d564b 19}
20
0994c4d0 21if ($^O eq 'mpeix') {
22 print "1..0 # Skip: fork/status problems on MPE/iX\n";
23 exit 0;
24}
25
7766f137 26$|=1;
27
28undef $/;
29@prgs = split "\n########\n", <DATA>;
30print "1..", scalar @prgs, "\n";
31
32$tmpfile = "forktmp000";
331 while -f ++$tmpfile;
6b5cb48c 34END { close TEST; unlink $tmpfile if $tmpfile; }
7766f137 35
2986a63f 36$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat'));
8d063cd8 37
7766f137 38for (@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 }
2986a63f 54 elsif ($^O eq 'NetWare') {
55 $results = `perl -I../lib $switch $tmpfile 2>&1`;
56 }
7766f137 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;
6b5cb48c 67 $results =~ s/^\n*Process terminated by SIG\w+\n?//mg
68 if $^O eq 'os2';
7766f137 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;
8d063cd8 81if ($cid = fork) {
7766f137 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
8d063cd8 90}
91else {
8d063cd8 92 print "ok 1\n";
93 sleep 10;
94}
7766f137 95EXPECT
96ok 1
97ok 2
98########
99$| = 1;
100sub forkit {
101 print "iteration $i start\n";
102 my $x = fork;
103 if (defined $x) {
104 if ($x) {
105 print "iteration $i parent\n";
106 }
107 else {
108 print "iteration $i child\n";
109 }
110 }
111 else {
112 print "pid $$ failed to fork\n";
113 }
114}
115while ($i++ < 3) { do { forkit(); }; }
116EXPECT
117iteration 1 start
118iteration 1 parent
119iteration 1 child
120iteration 2 start
121iteration 2 parent
122iteration 2 child
123iteration 2 start
124iteration 2 parent
125iteration 2 child
126iteration 3 start
127iteration 3 parent
128iteration 3 child
129iteration 3 start
130iteration 3 parent
131iteration 3 child
132iteration 3 start
133iteration 3 parent
134iteration 3 child
135iteration 3 start
136iteration 3 parent
137iteration 3 child
138########
139$| = 1;
140fork()
141 ? (print("parent\n"),sleep(1))
142 : (print("child\n"),exit) ;
143EXPECT
144parent
145child
146########
147$| = 1;
148fork()
149 ? (print("parent\n"),exit)
150 : (print("child\n"),sleep(1)) ;
151EXPECT
152parent
153child
154########
155$| = 1;
156@a = (1..3);
157for (@a) {
158 if (fork) {
159 print "parent $_\n";
160 $_ = "[$_]";
161 }
162 else {
163 print "child $_\n";
164 $_ = "-$_-";
165 }
166}
167print "@a\n";
168EXPECT
169parent 1
170child 1
171parent 2
172child 2
173parent 2
174child 2
175parent 3
176child 3
177parent 3
178child 3
179parent 3
180child 3
181parent 3
182child 3
183[1] [2] [3]
184-1- [2] [3]
185[1] -2- [3]
186[1] [2] -3-
187-1- -2- [3]
188-1- [2] -3-
189[1] -2- -3-
190-1- -2- -3-
191########
c3564e5c 192$| = 1;
193foreach my $c (1,2,3) {
194 if (fork) {
195 print "parent $c\n";
196 }
197 else {
198 print "child $c\n";
199 exit;
200 }
201}
202while (wait() != -1) { print "waited\n" }
203EXPECT
204child 1
205child 2
206child 3
207parent 1
208parent 2
209parent 3
210waited
211waited
212waited
213########
7766f137 214use Config;
215$| = 1;
216$\ = "\n";
217fork()
218 ? print($Config{osname} eq $^O)
219 : print($Config{osname} eq $^O) ;
220EXPECT
2211
2221
223########
224$| = 1;
225$\ = "\n";
226fork()
227 ? do { require Config; print($Config::Config{osname} eq $^O); }
228 : do { require Config; print($Config::Config{osname} eq $^O); }
229EXPECT
2301
2311
232########
233$| = 1;
234use Cwd;
235$\ = "\n";
236my $dir;
237if (fork) {
238 $dir = "f$$.tst";
239 mkdir $dir, 0755;
240 chdir $dir;
241 print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
242 chdir "..";
243 rmdir $dir;
244}
245else {
246 sleep 2;
247 $dir = "f$$.tst";
248 mkdir $dir, 0755;
249 chdir $dir;
250 print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
251 chdir "..";
252 rmdir $dir;
253}
254EXPECT
255ok 1 parent
256ok 1 child
257########
258$| = 1;
259$\ = "\n";
260my $getenv;
2986a63f 261if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
7766f137 262 $getenv = qq[$^X -e "print \$ENV{TST}"];
263}
264else {
265 $getenv = qq[$^X -e 'print \$ENV{TST}'];
266}
35424068 267$ENV{TST} = 'foo';
7766f137 268if (fork) {
269 sleep 1;
35424068 270 print "parent before: " . `$getenv`;
271 $ENV{TST} = 'bar';
272 print "parent after: " . `$getenv`;
7766f137 273}
274else {
35424068 275 print "child before: " . `$getenv`;
276 $ENV{TST} = 'baz';
277 print "child after: " . `$getenv`;
7766f137 278}
279EXPECT
35424068 280child before: foo
281child after: baz
282parent before: foo
283parent after: bar
7766f137 284########
285$| = 1;
286$\ = "\n";
287if ($pid = fork) {
288 waitpid($pid,0);
289 print "parent got $?"
290}
291else {
292 exit(42);
293}
294EXPECT
295parent got 10752
296########
297$| = 1;
298$\ = "\n";
299my $echo = 'echo';
300if ($pid = fork) {
301 waitpid($pid,0);
302 print "parent got $?"
303}
304else {
305 exec("$echo foo");
306}
307EXPECT
308foo
309parent got 0
310########
311if (fork) {
312 die "parent died";
313}
314else {
315 die "child died";
316}
317EXPECT
318parent died at - line 2.
319child died at - line 5.
320########
321if ($pid = fork) {
322 eval { die "parent died" };
323 print $@;
324}
325else {
326 eval { die "child died" };
327 print $@;
328}
329EXPECT
330parent died at - line 2.
331child died at - line 6.
332########
333if (eval q{$pid = fork}) {
334 eval q{ die "parent died" };
335 print $@;
336}
337else {
338 eval q{ die "child died" };
339 print $@;
340}
341EXPECT
342parent died at (eval 2) line 1.
343child died at (eval 2) line 1.
344########
345BEGIN {
346 $| = 1;
347 fork and exit;
348 print "inner\n";
349}
350# XXX In emulated fork(), the child will not execute anything after
351# the BEGIN block, due to difficulties in recreating the parse stacks
352# and restarting yyparse() midstream in the child. This can potentially
353# be overcome by treating what's after the BEGIN{} as a brand new parse.
354#print "outer\n"
355EXPECT
356inner
030866aa 357########
358sub pipe_to_fork ($$) {
359 my $parent = shift;
360 my $child = shift;
361 pipe($child, $parent) or die;
362 my $pid = fork();
363 die "fork() failed: $!" unless defined $pid;
364 close($pid ? $child : $parent);
365 $pid;
366}
367
368if (pipe_to_fork('PARENT','CHILD')) {
369 # parent
370 print PARENT "pipe_to_fork\n";
371 close PARENT;
372}
373else {
374 # child
375 while (<CHILD>) { print; }
376 close CHILD;
377 exit;
378}
379
380sub pipe_from_fork ($$) {
381 my $parent = shift;
382 my $child = shift;
383 pipe($parent, $child) or die;
384 my $pid = fork();
385 die "fork() failed: $!" unless defined $pid;
386 close($pid ? $child : $parent);
387 $pid;
388}
389
390if (pipe_from_fork('PARENT','CHILD')) {
391 # parent
392 while (<PARENT>) { print; }
393 close PARENT;
394}
395else {
396 # child
397 print CHILD "pipe_from_fork\n";
398 close CHILD;
399 exit;
400}
401EXPECT
402pipe_from_fork
403pipe_to_fork
68a29c53 404########
10d51319 405$|=1;
68a29c53 406if ($pid = fork()) {
407 print "forked first kid\n";
408 print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
409}
410else {
411 print "first child\n";
412 exit(0);
413}
414if ($pid = fork()) {
415 print "forked second kid\n";
416 print "wait() returned ok\n" if wait() == $pid;
417}
418else {
419 print "second child\n";
420 exit(0);
421}
422EXPECT
423forked first kid
424first child
425waitpid() returned ok
426forked second kid
427second child
428wait() returned ok