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