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 | |
7766f137 |
19 | $|=1; |
20 | |
21 | undef $/; |
22 | @prgs = split "\n########\n", <DATA>; |
23 | print "1..", scalar @prgs, "\n"; |
24 | |
25 | $tmpfile = "forktmp000"; |
26 | 1 while -f ++$tmpfile; |
27 | END { unlink $tmpfile if $tmpfile; } |
28 | |
29 | $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); |
8d063cd8 |
30 | |
7766f137 |
31 | for (@prgs){ |
32 | my $switch; |
33 | if (s/^\s*(-\w.*)//){ |
34 | $switch = $1; |
35 | } |
36 | my($prog,$expected) = split(/\nEXPECT\n/, $_); |
37 | $expected =~ s/\n+$//; |
38 | # results can be in any order, so sort 'em |
39 | my @expected = sort split /\n/, $expected; |
40 | open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; |
41 | print TEST $prog, "\n"; |
42 | close TEST or die "Cannot close $tmpfile: $!"; |
43 | my $results; |
44 | if ($^O eq 'MSWin32') { |
45 | $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; |
46 | } |
47 | else { |
48 | $results = `./perl $switch $tmpfile 2>&1`; |
49 | } |
50 | $status = $?; |
51 | $results =~ s/\n+$//; |
52 | $results =~ s/at\s+forktmp\d+\s+line/at - line/g; |
53 | $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g; |
54 | # bison says 'parse error' instead of 'syntax error', |
55 | # various yaccs may or may not capitalize 'syntax'. |
56 | $results =~ s/^(syntax|parse) error/syntax error/mig; |
57 | my @results = sort split /\n/, $results; |
58 | if ( "@results" ne "@expected" ) { |
59 | print STDERR "PROG: $switch\n$prog\n"; |
60 | print STDERR "EXPECTED:\n$expected\n"; |
61 | print STDERR "GOT:\n$results\n"; |
62 | print "not "; |
63 | } |
64 | print "ok ", ++$i, "\n"; |
65 | } |
66 | |
67 | __END__ |
68 | $| = 1; |
8d063cd8 |
69 | if ($cid = fork) { |
7766f137 |
70 | sleep 1; |
71 | if ($result = (kill 9, $cid)) { |
72 | print "ok 2\n"; |
73 | } |
74 | else { |
75 | print "not ok 2 $result\n"; |
76 | } |
77 | sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug |
8d063cd8 |
78 | } |
79 | else { |
8d063cd8 |
80 | print "ok 1\n"; |
81 | sleep 10; |
82 | } |
7766f137 |
83 | EXPECT |
84 | ok 1 |
85 | ok 2 |
86 | ######## |
87 | $| = 1; |
88 | sub forkit { |
89 | print "iteration $i start\n"; |
90 | my $x = fork; |
91 | if (defined $x) { |
92 | if ($x) { |
93 | print "iteration $i parent\n"; |
94 | } |
95 | else { |
96 | print "iteration $i child\n"; |
97 | } |
98 | } |
99 | else { |
100 | print "pid $$ failed to fork\n"; |
101 | } |
102 | } |
103 | while ($i++ < 3) { do { forkit(); }; } |
104 | EXPECT |
105 | iteration 1 start |
106 | iteration 1 parent |
107 | iteration 1 child |
108 | iteration 2 start |
109 | iteration 2 parent |
110 | iteration 2 child |
111 | iteration 2 start |
112 | iteration 2 parent |
113 | iteration 2 child |
114 | iteration 3 start |
115 | iteration 3 parent |
116 | iteration 3 child |
117 | iteration 3 start |
118 | iteration 3 parent |
119 | iteration 3 child |
120 | iteration 3 start |
121 | iteration 3 parent |
122 | iteration 3 child |
123 | iteration 3 start |
124 | iteration 3 parent |
125 | iteration 3 child |
126 | ######## |
127 | $| = 1; |
128 | fork() |
129 | ? (print("parent\n"),sleep(1)) |
130 | : (print("child\n"),exit) ; |
131 | EXPECT |
132 | parent |
133 | child |
134 | ######## |
135 | $| = 1; |
136 | fork() |
137 | ? (print("parent\n"),exit) |
138 | : (print("child\n"),sleep(1)) ; |
139 | EXPECT |
140 | parent |
141 | child |
142 | ######## |
143 | $| = 1; |
144 | @a = (1..3); |
145 | for (@a) { |
146 | if (fork) { |
147 | print "parent $_\n"; |
148 | $_ = "[$_]"; |
149 | } |
150 | else { |
151 | print "child $_\n"; |
152 | $_ = "-$_-"; |
153 | } |
154 | } |
155 | print "@a\n"; |
156 | EXPECT |
157 | parent 1 |
158 | child 1 |
159 | parent 2 |
160 | child 2 |
161 | parent 2 |
162 | child 2 |
163 | parent 3 |
164 | child 3 |
165 | parent 3 |
166 | child 3 |
167 | parent 3 |
168 | child 3 |
169 | parent 3 |
170 | child 3 |
171 | [1] [2] [3] |
172 | -1- [2] [3] |
173 | [1] -2- [3] |
174 | [1] [2] -3- |
175 | -1- -2- [3] |
176 | -1- [2] -3- |
177 | [1] -2- -3- |
178 | -1- -2- -3- |
179 | ######## |
180 | use Config; |
181 | $| = 1; |
182 | $\ = "\n"; |
183 | fork() |
184 | ? print($Config{osname} eq $^O) |
185 | : print($Config{osname} eq $^O) ; |
186 | EXPECT |
187 | 1 |
188 | 1 |
189 | ######## |
190 | $| = 1; |
191 | $\ = "\n"; |
192 | fork() |
193 | ? do { require Config; print($Config::Config{osname} eq $^O); } |
194 | : do { require Config; print($Config::Config{osname} eq $^O); } |
195 | EXPECT |
196 | 1 |
197 | 1 |
198 | ######## |
199 | $| = 1; |
200 | use Cwd; |
201 | $\ = "\n"; |
202 | my $dir; |
203 | if (fork) { |
204 | $dir = "f$$.tst"; |
205 | mkdir $dir, 0755; |
206 | chdir $dir; |
207 | print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; |
208 | chdir ".."; |
209 | rmdir $dir; |
210 | } |
211 | else { |
212 | sleep 2; |
213 | $dir = "f$$.tst"; |
214 | mkdir $dir, 0755; |
215 | chdir $dir; |
216 | print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; |
217 | chdir ".."; |
218 | rmdir $dir; |
219 | } |
220 | EXPECT |
221 | ok 1 parent |
222 | ok 1 child |
223 | ######## |
224 | $| = 1; |
225 | $\ = "\n"; |
226 | my $getenv; |
227 | if ($^O eq 'MSWin32') { |
228 | $getenv = qq[$^X -e "print \$ENV{TST}"]; |
229 | } |
230 | else { |
231 | $getenv = qq[$^X -e 'print \$ENV{TST}']; |
232 | } |
35424068 |
233 | $ENV{TST} = 'foo'; |
7766f137 |
234 | if (fork) { |
235 | sleep 1; |
35424068 |
236 | print "parent before: " . `$getenv`; |
237 | $ENV{TST} = 'bar'; |
238 | print "parent after: " . `$getenv`; |
7766f137 |
239 | } |
240 | else { |
35424068 |
241 | print "child before: " . `$getenv`; |
242 | $ENV{TST} = 'baz'; |
243 | print "child after: " . `$getenv`; |
7766f137 |
244 | } |
245 | EXPECT |
35424068 |
246 | child before: foo |
247 | child after: baz |
248 | parent before: foo |
249 | parent after: bar |
7766f137 |
250 | ######## |
251 | $| = 1; |
252 | $\ = "\n"; |
253 | if ($pid = fork) { |
254 | waitpid($pid,0); |
255 | print "parent got $?" |
256 | } |
257 | else { |
258 | exit(42); |
259 | } |
260 | EXPECT |
261 | parent got 10752 |
262 | ######## |
263 | $| = 1; |
264 | $\ = "\n"; |
265 | my $echo = 'echo'; |
266 | if ($pid = fork) { |
267 | waitpid($pid,0); |
268 | print "parent got $?" |
269 | } |
270 | else { |
271 | exec("$echo foo"); |
272 | } |
273 | EXPECT |
274 | foo |
275 | parent got 0 |
276 | ######## |
277 | if (fork) { |
278 | die "parent died"; |
279 | } |
280 | else { |
281 | die "child died"; |
282 | } |
283 | EXPECT |
284 | parent died at - line 2. |
285 | child died at - line 5. |
286 | ######## |
287 | if ($pid = fork) { |
288 | eval { die "parent died" }; |
289 | print $@; |
290 | } |
291 | else { |
292 | eval { die "child died" }; |
293 | print $@; |
294 | } |
295 | EXPECT |
296 | parent died at - line 2. |
297 | child died at - line 6. |
298 | ######## |
299 | if (eval q{$pid = fork}) { |
300 | eval q{ die "parent died" }; |
301 | print $@; |
302 | } |
303 | else { |
304 | eval q{ die "child died" }; |
305 | print $@; |
306 | } |
307 | EXPECT |
308 | parent died at (eval 2) line 1. |
309 | child died at (eval 2) line 1. |
310 | ######## |
311 | BEGIN { |
312 | $| = 1; |
313 | fork and exit; |
314 | print "inner\n"; |
315 | } |
316 | # XXX In emulated fork(), the child will not execute anything after |
317 | # the BEGIN block, due to difficulties in recreating the parse stacks |
318 | # and restarting yyparse() midstream in the child. This can potentially |
319 | # be overcome by treating what's after the BEGIN{} as a brand new parse. |
320 | #print "outer\n" |
321 | EXPECT |
322 | inner |
030866aa |
323 | ######## |
324 | sub pipe_to_fork ($$) { |
325 | my $parent = shift; |
326 | my $child = shift; |
327 | pipe($child, $parent) or die; |
328 | my $pid = fork(); |
329 | die "fork() failed: $!" unless defined $pid; |
330 | close($pid ? $child : $parent); |
331 | $pid; |
332 | } |
333 | |
334 | if (pipe_to_fork('PARENT','CHILD')) { |
335 | # parent |
336 | print PARENT "pipe_to_fork\n"; |
337 | close PARENT; |
338 | } |
339 | else { |
340 | # child |
341 | while (<CHILD>) { print; } |
342 | close CHILD; |
343 | exit; |
344 | } |
345 | |
346 | sub pipe_from_fork ($$) { |
347 | my $parent = shift; |
348 | my $child = shift; |
349 | pipe($parent, $child) or die; |
350 | my $pid = fork(); |
351 | die "fork() failed: $!" unless defined $pid; |
352 | close($pid ? $child : $parent); |
353 | $pid; |
354 | } |
355 | |
356 | if (pipe_from_fork('PARENT','CHILD')) { |
357 | # parent |
358 | while (<PARENT>) { print; } |
359 | close PARENT; |
360 | } |
361 | else { |
362 | # child |
363 | print CHILD "pipe_from_fork\n"; |
364 | close CHILD; |
365 | exit; |
366 | } |
367 | EXPECT |
368 | pipe_from_fork |
369 | pipe_to_fork |