Commit | Line | Data |
8d063cd8 |
1 | #!./perl |
2 | |
7766f137 |
3 | # tests for both real and emulated fork() |
8d063cd8 |
4 | |
774d564b |
5 | BEGIN { |
6 | chdir 't' if -d 't'; |
93430cb4 |
7 | unshift @INC, '../lib'; |
774d564b |
8 | require Config; import Config; |
dfdd1393 |
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 |
19 | if ($^O eq 'mpeix') { |
20 | print "1..0 # Skip: fork/status problems on MPE/iX\n"; |
21 | exit 0; |
22 | } |
23 | |
7766f137 |
24 | $|=1; |
25 | |
26 | undef $/; |
27 | @prgs = split "\n########\n", <DATA>; |
28 | print "1..", scalar @prgs, "\n"; |
29 | |
30 | $tmpfile = "forktmp000"; |
31 | 1 while -f ++$tmpfile; |
6b5cb48c |
32 | END { close TEST; unlink $tmpfile if $tmpfile; } |
7766f137 |
33 | |
34 | $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); |
8d063cd8 |
35 | |
7766f137 |
36 | for (@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 |
62 | $results =~ s/^\n*Process terminated by SIG\w+\n?//mg |
63 | if $^O eq 'os2'; |
7766f137 |
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 |
76 | if ($cid = fork) { |
7766f137 |
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 |
85 | } |
86 | else { |
8d063cd8 |
87 | print "ok 1\n"; |
88 | sleep 10; |
89 | } |
7766f137 |
90 | EXPECT |
91 | ok 1 |
92 | ok 2 |
93 | ######## |
94 | $| = 1; |
95 | sub 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 | } |
110 | while ($i++ < 3) { do { forkit(); }; } |
111 | EXPECT |
112 | iteration 1 start |
113 | iteration 1 parent |
114 | iteration 1 child |
115 | iteration 2 start |
116 | iteration 2 parent |
117 | iteration 2 child |
118 | iteration 2 start |
119 | iteration 2 parent |
120 | iteration 2 child |
121 | iteration 3 start |
122 | iteration 3 parent |
123 | iteration 3 child |
124 | iteration 3 start |
125 | iteration 3 parent |
126 | iteration 3 child |
127 | iteration 3 start |
128 | iteration 3 parent |
129 | iteration 3 child |
130 | iteration 3 start |
131 | iteration 3 parent |
132 | iteration 3 child |
133 | ######## |
134 | $| = 1; |
135 | fork() |
136 | ? (print("parent\n"),sleep(1)) |
137 | : (print("child\n"),exit) ; |
138 | EXPECT |
139 | parent |
140 | child |
141 | ######## |
142 | $| = 1; |
143 | fork() |
144 | ? (print("parent\n"),exit) |
145 | : (print("child\n"),sleep(1)) ; |
146 | EXPECT |
147 | parent |
148 | child |
149 | ######## |
150 | $| = 1; |
151 | @a = (1..3); |
152 | for (@a) { |
153 | if (fork) { |
154 | print "parent $_\n"; |
155 | $_ = "[$_]"; |
156 | } |
157 | else { |
158 | print "child $_\n"; |
159 | $_ = "-$_-"; |
160 | } |
161 | } |
162 | print "@a\n"; |
163 | EXPECT |
164 | parent 1 |
165 | child 1 |
166 | parent 2 |
167 | child 2 |
168 | parent 2 |
169 | child 2 |
170 | parent 3 |
171 | child 3 |
172 | parent 3 |
173 | child 3 |
174 | parent 3 |
175 | child 3 |
176 | parent 3 |
177 | child 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 | ######## |
187 | use Config; |
188 | $| = 1; |
189 | $\ = "\n"; |
190 | fork() |
191 | ? print($Config{osname} eq $^O) |
192 | : print($Config{osname} eq $^O) ; |
193 | EXPECT |
194 | 1 |
195 | 1 |
196 | ######## |
197 | $| = 1; |
198 | $\ = "\n"; |
199 | fork() |
200 | ? do { require Config; print($Config::Config{osname} eq $^O); } |
201 | : do { require Config; print($Config::Config{osname} eq $^O); } |
202 | EXPECT |
203 | 1 |
204 | 1 |
205 | ######## |
206 | $| = 1; |
207 | use Cwd; |
208 | $\ = "\n"; |
209 | my $dir; |
210 | if (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 | } |
218 | else { |
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 | } |
227 | EXPECT |
228 | ok 1 parent |
229 | ok 1 child |
230 | ######## |
231 | $| = 1; |
232 | $\ = "\n"; |
233 | my $getenv; |
234 | if ($^O eq 'MSWin32') { |
235 | $getenv = qq[$^X -e "print \$ENV{TST}"]; |
236 | } |
237 | else { |
238 | $getenv = qq[$^X -e 'print \$ENV{TST}']; |
239 | } |
35424068 |
240 | $ENV{TST} = 'foo'; |
7766f137 |
241 | if (fork) { |
242 | sleep 1; |
35424068 |
243 | print "parent before: " . `$getenv`; |
244 | $ENV{TST} = 'bar'; |
245 | print "parent after: " . `$getenv`; |
7766f137 |
246 | } |
247 | else { |
35424068 |
248 | print "child before: " . `$getenv`; |
249 | $ENV{TST} = 'baz'; |
250 | print "child after: " . `$getenv`; |
7766f137 |
251 | } |
252 | EXPECT |
35424068 |
253 | child before: foo |
254 | child after: baz |
255 | parent before: foo |
256 | parent after: bar |
7766f137 |
257 | ######## |
258 | $| = 1; |
259 | $\ = "\n"; |
260 | if ($pid = fork) { |
261 | waitpid($pid,0); |
262 | print "parent got $?" |
263 | } |
264 | else { |
265 | exit(42); |
266 | } |
267 | EXPECT |
268 | parent got 10752 |
269 | ######## |
270 | $| = 1; |
271 | $\ = "\n"; |
272 | my $echo = 'echo'; |
273 | if ($pid = fork) { |
274 | waitpid($pid,0); |
275 | print "parent got $?" |
276 | } |
277 | else { |
278 | exec("$echo foo"); |
279 | } |
280 | EXPECT |
281 | foo |
282 | parent got 0 |
283 | ######## |
284 | if (fork) { |
285 | die "parent died"; |
286 | } |
287 | else { |
288 | die "child died"; |
289 | } |
290 | EXPECT |
291 | parent died at - line 2. |
292 | child died at - line 5. |
293 | ######## |
294 | if ($pid = fork) { |
295 | eval { die "parent died" }; |
296 | print $@; |
297 | } |
298 | else { |
299 | eval { die "child died" }; |
300 | print $@; |
301 | } |
302 | EXPECT |
303 | parent died at - line 2. |
304 | child died at - line 6. |
305 | ######## |
306 | if (eval q{$pid = fork}) { |
307 | eval q{ die "parent died" }; |
308 | print $@; |
309 | } |
310 | else { |
311 | eval q{ die "child died" }; |
312 | print $@; |
313 | } |
314 | EXPECT |
315 | parent died at (eval 2) line 1. |
316 | child died at (eval 2) line 1. |
317 | ######## |
318 | BEGIN { |
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" |
328 | EXPECT |
329 | inner |
030866aa |
330 | ######## |
331 | sub 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 | |
341 | if (pipe_to_fork('PARENT','CHILD')) { |
342 | # parent |
343 | print PARENT "pipe_to_fork\n"; |
344 | close PARENT; |
345 | } |
346 | else { |
347 | # child |
348 | while (<CHILD>) { print; } |
349 | close CHILD; |
350 | exit; |
351 | } |
352 | |
353 | sub 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 | |
363 | if (pipe_from_fork('PARENT','CHILD')) { |
364 | # parent |
365 | while (<PARENT>) { print; } |
366 | close PARENT; |
367 | } |
368 | else { |
369 | # child |
370 | print CHILD "pipe_from_fork\n"; |
371 | close CHILD; |
372 | exit; |
373 | } |
374 | EXPECT |
375 | pipe_from_fork |
376 | pipe_to_fork |