This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pod nit seen in passing
[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';
93430cb4 7 unshift @INC, '../lib';
774d564b 8 require Config; import Config;
dfdd1393
GS
9 unless ($Config{'d_fork'}
10 or ($^O eq 'MSWin32' and $Config{useithreads}
11 and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/))
12 {
45c0de28 13 print "1..0 # Skip: no fork\n";
774d564b 14 exit 0;
15 }
7766f137 16 $ENV{PERL5LIB} = "../lib";
774d564b 17}
18
0994c4d0
JH
19if ($^O eq 'mpeix') {
20 print "1..0 # Skip: fork/status problems on MPE/iX\n";
21 exit 0;
22}
23
7766f137
GS
24$|=1;
25
26undef $/;
27@prgs = split "\n########\n", <DATA>;
28print "1..", scalar @prgs, "\n";
29
30$tmpfile = "forktmp000";
311 while -f ++$tmpfile;
6b5cb48c 32END { close TEST; unlink $tmpfile if $tmpfile; }
7766f137
GS
33
34$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat');
8d063cd8 35
7766f137
GS
36for (@prgs){
37 my $switch;
38 if (s/^\s*(-\w.*)//){
39 $switch = $1;
40 }
41 my($prog,$expected) = split(/\nEXPECT\n/, $_);
42 $expected =~ s/\n+$//;
43 # results can be in any order, so sort 'em
44 my @expected = sort split /\n/, $expected;
45 open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
46 print TEST $prog, "\n";
47 close TEST or die "Cannot close $tmpfile: $!";
48 my $results;
49 if ($^O eq 'MSWin32') {
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;
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;
95sub forkit {
96 print "iteration $i start\n";
97 my $x = fork;
98 if (defined $x) {
99 if ($x) {
100 print "iteration $i parent\n";
101 }
102 else {
103 print "iteration $i child\n";
104 }
105 }
106 else {
107 print "pid $$ failed to fork\n";
108 }
109}
110while ($i++ < 3) { do { forkit(); }; }
111EXPECT
112iteration 1 start
113iteration 1 parent
114iteration 1 child
115iteration 2 start
116iteration 2 parent
117iteration 2 child
118iteration 2 start
119iteration 2 parent
120iteration 2 child
121iteration 3 start
122iteration 3 parent
123iteration 3 child
124iteration 3 start
125iteration 3 parent
126iteration 3 child
127iteration 3 start
128iteration 3 parent
129iteration 3 child
130iteration 3 start
131iteration 3 parent
132iteration 3 child
133########
134$| = 1;
135fork()
136 ? (print("parent\n"),sleep(1))
137 : (print("child\n"),exit) ;
138EXPECT
139parent
140child
141########
142$| = 1;
143fork()
144 ? (print("parent\n"),exit)
145 : (print("child\n"),sleep(1)) ;
146EXPECT
147parent
148child
149########
150$| = 1;
151@a = (1..3);
152for (@a) {
153 if (fork) {
154 print "parent $_\n";
155 $_ = "[$_]";
156 }
157 else {
158 print "child $_\n";
159 $_ = "-$_-";
160 }
161}
162print "@a\n";
163EXPECT
164parent 1
165child 1
166parent 2
167child 2
168parent 2
169child 2
170parent 3
171child 3
172parent 3
173child 3
174parent 3
175child 3
176parent 3
177child 3
178[1] [2] [3]
179-1- [2] [3]
180[1] -2- [3]
181[1] [2] -3-
182-1- -2- [3]
183-1- [2] -3-
184[1] -2- -3-
185-1- -2- -3-
186########
187use Config;
188$| = 1;
189$\ = "\n";
190fork()
191 ? print($Config{osname} eq $^O)
192 : print($Config{osname} eq $^O) ;
193EXPECT
1941
1951
196########
197$| = 1;
198$\ = "\n";
199fork()
200 ? do { require Config; print($Config::Config{osname} eq $^O); }
201 : do { require Config; print($Config::Config{osname} eq $^O); }
202EXPECT
2031
2041
205########
206$| = 1;
207use Cwd;
208$\ = "\n";
209my $dir;
210if (fork) {
211 $dir = "f$$.tst";
212 mkdir $dir, 0755;
213 chdir $dir;
214 print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
215 chdir "..";
216 rmdir $dir;
217}
218else {
219 sleep 2;
220 $dir = "f$$.tst";
221 mkdir $dir, 0755;
222 chdir $dir;
223 print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
224 chdir "..";
225 rmdir $dir;
226}
227EXPECT
228ok 1 parent
229ok 1 child
230########
231$| = 1;
232$\ = "\n";
233my $getenv;
234if ($^O eq 'MSWin32') {
235 $getenv = qq[$^X -e "print \$ENV{TST}"];
236}
237else {
238 $getenv = qq[$^X -e 'print \$ENV{TST}'];
239}
35424068 240$ENV{TST} = 'foo';
7766f137
GS
241if (fork) {
242 sleep 1;
35424068
GS
243 print "parent before: " . `$getenv`;
244 $ENV{TST} = 'bar';
245 print "parent after: " . `$getenv`;
7766f137
GS
246}
247else {
35424068
GS
248 print "child before: " . `$getenv`;
249 $ENV{TST} = 'baz';
250 print "child after: " . `$getenv`;
7766f137
GS
251}
252EXPECT
35424068
GS
253child before: foo
254child after: baz
255parent before: foo
256parent after: bar
7766f137
GS
257########
258$| = 1;
259$\ = "\n";
260if ($pid = fork) {
261 waitpid($pid,0);
262 print "parent got $?"
263}
264else {
265 exit(42);
266}
267EXPECT
268parent got 10752
269########
270$| = 1;
271$\ = "\n";
272my $echo = 'echo';
273if ($pid = fork) {
274 waitpid($pid,0);
275 print "parent got $?"
276}
277else {
278 exec("$echo foo");
279}
280EXPECT
281foo
282parent got 0
283########
284if (fork) {
285 die "parent died";
286}
287else {
288 die "child died";
289}
290EXPECT
291parent died at - line 2.
292child died at - line 5.
293########
294if ($pid = fork) {
295 eval { die "parent died" };
296 print $@;
297}
298else {
299 eval { die "child died" };
300 print $@;
301}
302EXPECT
303parent died at - line 2.
304child died at - line 6.
305########
306if (eval q{$pid = fork}) {
307 eval q{ die "parent died" };
308 print $@;
309}
310else {
311 eval q{ die "child died" };
312 print $@;
313}
314EXPECT
315parent died at (eval 2) line 1.
316child died at (eval 2) line 1.
317########
318BEGIN {
319 $| = 1;
320 fork and exit;
321 print "inner\n";
322}
323# XXX In emulated fork(), the child will not execute anything after
324# the BEGIN block, due to difficulties in recreating the parse stacks
325# and restarting yyparse() midstream in the child. This can potentially
326# be overcome by treating what's after the BEGIN{} as a brand new parse.
327#print "outer\n"
328EXPECT
329inner
030866aa
GS
330########
331sub pipe_to_fork ($$) {
332 my $parent = shift;
333 my $child = shift;
334 pipe($child, $parent) or die;
335 my $pid = fork();
336 die "fork() failed: $!" unless defined $pid;
337 close($pid ? $child : $parent);
338 $pid;
339}
340
341if (pipe_to_fork('PARENT','CHILD')) {
342 # parent
343 print PARENT "pipe_to_fork\n";
344 close PARENT;
345}
346else {
347 # child
348 while (<CHILD>) { print; }
349 close CHILD;
350 exit;
351}
352
353sub pipe_from_fork ($$) {
354 my $parent = shift;
355 my $child = shift;
356 pipe($parent, $child) or die;
357 my $pid = fork();
358 die "fork() failed: $!" unless defined $pid;
359 close($pid ? $child : $parent);
360 $pid;
361}
362
363if (pipe_from_fork('PARENT','CHILD')) {
364 # parent
365 while (<PARENT>) { print; }
366 close PARENT;
367}
368else {
369 # child
370 print CHILD "pipe_from_fork\n";
371 close CHILD;
372 exit;
373}
374EXPECT
375pipe_from_fork
376pipe_to_fork