Commit | Line | Data |
---|---|---|
7473853a | 1 | use strict; |
a0e036c1 MP |
2 | use warnings; |
3 | ||
4 | BEGIN { | |
7473853a SP |
5 | if ($ENV{'PERL_CORE'}){ |
6 | chdir 't'; | |
7 | unshift @INC, '../lib'; | |
8 | } | |
9 | use Config; | |
10 | if (! $Config{'useithreads'}) { | |
11 | print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); | |
12 | exit(0); | |
a0e036c1 MP |
13 | } |
14 | } | |
a0e036c1 | 15 | |
a0e036c1 MP |
16 | use ExtUtils::testlib; |
17 | ||
18 | my $Base = 0; | |
a0e036c1 | 19 | sub ok { |
7473853a SP |
20 | my ($id, $ok, $name) = @_; |
21 | $id += $Base; | |
22 | ||
23 | # You have to do it this way or VMS will get confused. | |
24 | if ($ok) { | |
25 | print("ok $id - $name\n"); | |
26 | } else { | |
27 | print("not ok $id - $name\n"); | |
28 | printf("# Failed test at line %d\n", (caller)[2]); | |
29 | } | |
30 | ||
31 | return ($ok); | |
a0e036c1 MP |
32 | } |
33 | ||
7473853a SP |
34 | BEGIN { |
35 | $| = 1; | |
f38680ff | 36 | print("1..91\n"); ### Number of tests that will be run ### |
7473853a SP |
37 | }; |
38 | ||
39 | use threads; | |
40 | use threads::shared; | |
41 | ok(1, 1, 'Loaded'); | |
42 | $Base++; | |
43 | ||
44 | ### Start of Testing ### | |
45 | ||
46 | # cond_wait and cond_timedwait extended tests adapted from cond.t | |
47 | ||
80b2a687 MB |
48 | # The two skips later on in these tests refer to this quote from the |
49 | # pod/perl583delta.pod: | |
50 | # | |
51 | # =head1 Platform Specific Problems | |
7473853a | 52 | # |
80b2a687 MB |
53 | # The regression test ext/threads/shared/t/wait.t fails on early RedHat 9 |
54 | # and HP-UX 10.20 due to bugs in their threading implementations. | |
55 | # RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html | |
56 | # and consider upgrading their glibc. | |
57 | ||
f38680ff | 58 | |
87c9b3a6 MP |
59 | sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in |
60 | # stock RH9 glibc/NPTL) or from our own errors, we run tests | |
61 | # in separately forked and alarmed processes. | |
62 | ||
a56b3a00 | 63 | *forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i) |
87c9b3a6 MP |
64 | ? sub (&$$) { my $code = shift; goto &$code; } |
65 | : sub (&$$) { | |
66 | my ($code, $expected, $patience) = @_; | |
67 | my ($test_num, $pid); | |
68 | local *CHLD; | |
69 | ||
70 | my $bump = $expected; | |
71 | ||
87c9b3a6 MP |
72 | unless (defined($pid = open(CHLD, "-|"))) { |
73 | die "fork: $!\n"; | |
74 | } | |
75 | if (! $pid) { # Child -- run the test | |
f38680ff | 76 | alarm($patience || 60); |
87c9b3a6 MP |
77 | &$code; |
78 | exit; | |
79 | } | |
80 | ||
81 | while (<CHLD>) { | |
82 | $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/; | |
83 | #print "#forko: ($expected, $1) $_"; | |
84 | print; | |
85 | } | |
86 | ||
87 | close(CHLD); | |
88 | ||
89 | while ($expected--) { | |
f38680ff | 90 | ok(++$test_num, 0, "missing test result: child status $?"); |
87c9b3a6 MP |
91 | } |
92 | ||
93 | $Base += $bump; | |
87c9b3a6 MP |
94 | }; |
95 | ||
f38680ff | 96 | |
a0e036c1 MP |
97 | # - TEST basics |
98 | ||
99 | ok(1, defined &cond_wait, "cond_wait() present"); | |
100 | ok(2, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'), | |
101 | q|cond_wait() prototype '\[$@%];\[$@%]'|); | |
102 | ok(3, defined &cond_timedwait, "cond_timedwait() present"); | |
103 | ok(4, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'), | |
104 | q|cond_timedwait() prototype '\[$@%]$;\[$@%]'|); | |
105 | ||
106 | $Base += 4; | |
107 | ||
108 | my @wait_how = ( | |
109 | "simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c) | |
110 | "repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c) | |
111 | "twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l) | |
112 | ); | |
113 | ||
114 | SYNC_SHARED: { | |
115 | my $test : shared; # simple|repeat|twain | |
116 | my $cond : shared; | |
117 | my $lock : shared; | |
118 | ||
119 | ok(1, 1, "Shared synchronization tests preparation"); | |
120 | $Base += 1; | |
121 | ||
122 | sub signaller { | |
123 | ok(2,1,"$test: child before lock"); | |
124 | $test =~ /twain/ ? lock($lock) : lock($cond); | |
125 | ok(3,1,"$test: child obtained lock"); | |
126 | if ($test =~ 'twain') { | |
127 | no warnings 'threads'; # lock var != cond var, so disable warnings | |
128 | cond_signal($cond); | |
129 | } else { | |
130 | cond_signal($cond); | |
131 | } | |
132 | ok(4,1,"$test: child signalled condition"); | |
133 | } | |
134 | ||
135 | # - TEST cond_wait | |
87c9b3a6 MP |
136 | forko( sub { |
137 | foreach (@wait_how) { | |
138 | $test = "cond_wait [$_]"; | |
139 | threads->create(\&cw)->join; | |
f38680ff | 140 | $Base += 5; |
87c9b3a6 | 141 | } |
f38680ff | 142 | }, 5*@wait_how, 90); |
a0e036c1 MP |
143 | |
144 | sub cw { | |
f38680ff | 145 | # which lock to obtain? |
ee23bc3a MP |
146 | $test =~ /twain/ ? lock($lock) : lock($cond); |
147 | ok(1,1, "$test: obtained initial lock"); | |
148 | ||
f38680ff | 149 | my $thr = threads->create(\&signaller); |
ee23bc3a MP |
150 | for ($test) { |
151 | cond_wait($cond), last if /simple/; | |
152 | cond_wait($cond, $cond), last if /repeat/; | |
153 | cond_wait($cond, $lock), last if /twain/; | |
f38680ff | 154 | die "$test: unknown test\n"; |
ee23bc3a | 155 | } |
f38680ff | 156 | $thr->join; |
ee23bc3a | 157 | ok(5,1, "$test: condition obtained"); |
a0e036c1 MP |
158 | } |
159 | ||
160 | # - TEST cond_timedwait success | |
161 | ||
87c9b3a6 MP |
162 | forko( sub { |
163 | foreach (@wait_how) { | |
164 | $test = "cond_timedwait [$_]"; | |
165 | threads->create(\&ctw, 5)->join; | |
f38680ff | 166 | $Base += 5; |
87c9b3a6 | 167 | } |
f38680ff | 168 | }, 5*@wait_how, 90); |
a0e036c1 MP |
169 | |
170 | sub ctw($) { | |
f38680ff | 171 | my $to = shift; |
ee23bc3a | 172 | |
f38680ff | 173 | # which lock to obtain? |
ee23bc3a MP |
174 | $test =~ /twain/ ? lock($lock) : lock($cond); |
175 | ok(1,1, "$test: obtained initial lock"); | |
176 | ||
f38680ff | 177 | my $thr = threads->create(\&signaller); |
ee23bc3a MP |
178 | my $ok = 0; |
179 | for ($test) { | |
180 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; | |
181 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; | |
182 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; | |
f38680ff | 183 | die "$test: unknown test\n"; |
ee23bc3a | 184 | } |
f38680ff | 185 | $thr->join; |
ee23bc3a | 186 | ok(5,$ok, "$test: condition obtained"); |
a0e036c1 MP |
187 | } |
188 | ||
189 | # - TEST cond_timedwait timeout | |
190 | ||
87c9b3a6 MP |
191 | forko( sub { |
192 | foreach (@wait_how) { | |
193 | $test = "cond_timedwait pause, timeout [$_]"; | |
194 | threads->create(\&ctw_fail, 3)->join; | |
195 | $Base += 2; | |
196 | } | |
197 | }, 2*@wait_how, 90); | |
a0e036c1 | 198 | |
87c9b3a6 MP |
199 | forko( sub { |
200 | foreach (@wait_how) { | |
201 | $test = "cond_timedwait instant timeout [$_]"; | |
202 | threads->create(\&ctw_fail, -60)->join; | |
203 | $Base += 2; | |
204 | } | |
205 | }, 2*@wait_how, 90); | |
a0e036c1 MP |
206 | |
207 | # cond_timedwait timeout (relative timeout) | |
208 | sub ctw_fail { | |
209 | my $to = shift; | |
80b2a687 MB |
210 | if ($^O eq "hpux" && $Config{osvers} <= 10.20) { |
211 | # The lock obtaining would pass, but the wait will not. | |
212 | ok(1,1, "$test: obtained initial lock"); | |
213 | ok(2,0, "# SKIP see perl583delta"); | |
7473853a | 214 | } else { |
80b2a687 MB |
215 | $test =~ /twain/ ? lock($lock) : lock($cond); |
216 | ok(1,1, "$test: obtained initial lock"); | |
217 | my $ok; | |
218 | for ($test) { | |
7473853a SP |
219 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
220 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; | |
221 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; | |
f38680ff | 222 | die "$test: unknown test\n"; |
80b2a687 MB |
223 | } |
224 | ok(2,!defined($ok), "$test: timeout"); | |
a0e036c1 | 225 | } |
a0e036c1 MP |
226 | } |
227 | ||
228 | } # -- SYNCH_SHARED block | |
229 | ||
230 | ||
231 | # same as above, but with references to lock and cond vars | |
232 | ||
233 | SYNCH_REFS: { | |
234 | my $test : shared; # simple|repeat|twain | |
f38680ff | 235 | |
a0e036c1 MP |
236 | my $true_cond; share($true_cond); |
237 | my $true_lock; share($true_lock); | |
238 | ||
239 | my $cond = \$true_cond; | |
240 | my $lock = \$true_lock; | |
241 | ||
242 | ok(1, 1, "Synchronization reference tests preparation"); | |
243 | $Base += 1; | |
244 | ||
245 | sub signaller2 { | |
246 | ok(2,1,"$test: child before lock"); | |
247 | $test =~ /twain/ ? lock($lock) : lock($cond); | |
248 | ok(3,1,"$test: child obtained lock"); | |
249 | if ($test =~ 'twain') { | |
250 | no warnings 'threads'; # lock var != cond var, so disable warnings | |
251 | cond_signal($cond); | |
252 | } else { | |
253 | cond_signal($cond); | |
254 | } | |
255 | ok(4,1,"$test: child signalled condition"); | |
256 | } | |
257 | ||
258 | # - TEST cond_wait | |
87c9b3a6 MP |
259 | forko( sub { |
260 | foreach (@wait_how) { | |
261 | $test = "cond_wait [$_]"; | |
262 | threads->create(\&cw2)->join; | |
f38680ff | 263 | $Base += 5; |
87c9b3a6 | 264 | } |
f38680ff | 265 | }, 5*@wait_how, 90); |
a0e036c1 MP |
266 | |
267 | sub cw2 { | |
f38680ff | 268 | # which lock to obtain? |
ee23bc3a MP |
269 | $test =~ /twain/ ? lock($lock) : lock($cond); |
270 | ok(1,1, "$test: obtained initial lock"); | |
271 | ||
f38680ff | 272 | my $thr = threads->create(\&signaller2); |
ee23bc3a MP |
273 | for ($test) { |
274 | cond_wait($cond), last if /simple/; | |
275 | cond_wait($cond, $cond), last if /repeat/; | |
276 | cond_wait($cond, $lock), last if /twain/; | |
f38680ff | 277 | die "$test: unknown test\n"; |
ee23bc3a | 278 | } |
f38680ff | 279 | $thr->join; |
ee23bc3a | 280 | ok(5,1, "$test: condition obtained"); |
a0e036c1 MP |
281 | } |
282 | ||
283 | # - TEST cond_timedwait success | |
284 | ||
87c9b3a6 MP |
285 | forko( sub { |
286 | foreach (@wait_how) { | |
287 | $test = "cond_timedwait [$_]"; | |
288 | threads->create(\&ctw2, 5)->join; | |
f38680ff | 289 | $Base += 5; |
87c9b3a6 | 290 | } |
f38680ff | 291 | }, 5*@wait_how, 90); |
a0e036c1 MP |
292 | |
293 | sub ctw2($) { | |
f38680ff | 294 | my $to = shift; |
ee23bc3a | 295 | |
f38680ff | 296 | # which lock to obtain? |
ee23bc3a MP |
297 | $test =~ /twain/ ? lock($lock) : lock($cond); |
298 | ok(1,1, "$test: obtained initial lock"); | |
299 | ||
f38680ff | 300 | my $thr = threads->create(\&signaller2); |
ee23bc3a MP |
301 | my $ok = 0; |
302 | for ($test) { | |
303 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; | |
304 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; | |
305 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; | |
f38680ff | 306 | die "$test: unknown test\n"; |
ee23bc3a | 307 | } |
f38680ff | 308 | $thr->join; |
ee23bc3a | 309 | ok(5,$ok, "$test: condition obtained"); |
a0e036c1 MP |
310 | } |
311 | ||
312 | # - TEST cond_timedwait timeout | |
313 | ||
87c9b3a6 MP |
314 | forko( sub { |
315 | foreach (@wait_how) { | |
316 | $test = "cond_timedwait pause, timeout [$_]"; | |
317 | threads->create(\&ctw_fail2, 3)->join; | |
318 | $Base += 2; | |
319 | } | |
320 | }, 2*@wait_how, 90); | |
a0e036c1 | 321 | |
87c9b3a6 MP |
322 | forko( sub { |
323 | foreach (@wait_how) { | |
324 | $test = "cond_timedwait instant timeout [$_]"; | |
325 | threads->create(\&ctw_fail2, -60)->join; | |
326 | $Base += 2; | |
327 | } | |
328 | }, 2*@wait_how, 90); | |
a0e036c1 MP |
329 | |
330 | sub ctw_fail2 { | |
331 | my $to = shift; | |
332 | ||
80b2a687 MB |
333 | if ($^O eq "hpux" && $Config{osvers} <= 10.20) { |
334 | # The lock obtaining would pass, but the wait will not. | |
335 | ok(1,1, "$test: obtained initial lock"); | |
336 | ok(2,0, "# SKIP see perl583delta"); | |
7473853a | 337 | } else { |
80b2a687 MB |
338 | $test =~ /twain/ ? lock($lock) : lock($cond); |
339 | ok(1,1, "$test: obtained initial lock"); | |
340 | my $ok; | |
341 | for ($test) { | |
7473853a SP |
342 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
343 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; | |
344 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; | |
f38680ff | 345 | die "$test: unknown test\n"; |
80b2a687 MB |
346 | } |
347 | ok(2,!$ok, "$test: timeout"); | |
a0e036c1 | 348 | } |
a0e036c1 MP |
349 | } |
350 | ||
351 | } # -- SYNCH_REFS block | |
352 | ||
7473853a | 353 | # EOF |