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