Commit | Line | Data |
7473853a |
1 | use strict; |
a0e036c1 |
2 | use warnings; |
3 | |
4 | BEGIN { |
7473853a |
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 |
13 | } |
14 | } |
a0e036c1 |
15 | |
a0e036c1 |
16 | use ExtUtils::testlib; |
17 | |
18 | my $Base = 0; |
a0e036c1 |
19 | sub ok { |
7473853a |
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 |
32 | } |
33 | |
7473853a |
34 | BEGIN { |
35 | $| = 1; |
36 | print("1..103\n"); ### Number of tests that will be run ### |
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 |
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 |
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 | |
87c9b3a6 |
58 | sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in |
59 | # stock RH9 glibc/NPTL) or from our own errors, we run tests |
60 | # in separately forked and alarmed processes. |
61 | |
a56b3a00 |
62 | *forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i) |
87c9b3a6 |
63 | ? sub (&$$) { my $code = shift; goto &$code; } |
64 | : sub (&$$) { |
65 | my ($code, $expected, $patience) = @_; |
66 | my ($test_num, $pid); |
67 | local *CHLD; |
68 | |
69 | my $bump = $expected; |
70 | |
71 | $patience ||= 60; |
72 | |
73 | unless (defined($pid = open(CHLD, "-|"))) { |
74 | die "fork: $!\n"; |
75 | } |
76 | if (! $pid) { # Child -- run the test |
77 | $patience ||= 60; |
78 | alarm $patience; |
79 | &$code; |
80 | exit; |
81 | } |
82 | |
83 | while (<CHLD>) { |
84 | $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/; |
85 | #print "#forko: ($expected, $1) $_"; |
86 | print; |
87 | } |
88 | |
89 | close(CHLD); |
90 | |
91 | while ($expected--) { |
92 | $test_num++; |
93 | print "not ok $test_num - child status $?\n"; |
94 | } |
95 | |
96 | $Base += $bump; |
97 | |
98 | }; |
99 | |
a0e036c1 |
100 | # - TEST basics |
101 | |
102 | ok(1, defined &cond_wait, "cond_wait() present"); |
103 | ok(2, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'), |
104 | q|cond_wait() prototype '\[$@%];\[$@%]'|); |
105 | ok(3, defined &cond_timedwait, "cond_timedwait() present"); |
106 | ok(4, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'), |
107 | q|cond_timedwait() prototype '\[$@%]$;\[$@%]'|); |
108 | |
109 | $Base += 4; |
110 | |
111 | my @wait_how = ( |
112 | "simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c) |
113 | "repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c) |
114 | "twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l) |
115 | ); |
116 | |
117 | SYNC_SHARED: { |
118 | my $test : shared; # simple|repeat|twain |
119 | my $cond : shared; |
120 | my $lock : shared; |
121 | |
122 | ok(1, 1, "Shared synchronization tests preparation"); |
123 | $Base += 1; |
124 | |
125 | sub signaller { |
126 | ok(2,1,"$test: child before lock"); |
127 | $test =~ /twain/ ? lock($lock) : lock($cond); |
128 | ok(3,1,"$test: child obtained lock"); |
129 | if ($test =~ 'twain') { |
130 | no warnings 'threads'; # lock var != cond var, so disable warnings |
131 | cond_signal($cond); |
132 | } else { |
133 | cond_signal($cond); |
134 | } |
135 | ok(4,1,"$test: child signalled condition"); |
136 | } |
137 | |
138 | # - TEST cond_wait |
87c9b3a6 |
139 | forko( sub { |
140 | foreach (@wait_how) { |
141 | $test = "cond_wait [$_]"; |
142 | threads->create(\&cw)->join; |
143 | $Base += 6; |
144 | } |
145 | }, 6*@wait_how, 90); |
a0e036c1 |
146 | |
147 | sub cw { |
ee23bc3a |
148 | my $thr; |
149 | |
150 | { # -- begin lock scope; which lock to obtain? |
151 | $test =~ /twain/ ? lock($lock) : lock($cond); |
152 | ok(1,1, "$test: obtained initial lock"); |
153 | |
154 | $thr = threads->create(\&signaller); |
155 | for ($test) { |
156 | cond_wait($cond), last if /simple/; |
157 | cond_wait($cond, $cond), last if /repeat/; |
158 | cond_wait($cond, $lock), last if /twain/; |
159 | die "$test: unknown test\n"; |
160 | } |
161 | ok(5,1, "$test: condition obtained"); |
162 | } # -- end lock scope |
a0e036c1 |
163 | |
a0e036c1 |
164 | $thr->join; |
ee23bc3a |
165 | ok(6,1, "$test: join completed"); |
a0e036c1 |
166 | } |
167 | |
168 | # - TEST cond_timedwait success |
169 | |
87c9b3a6 |
170 | forko( sub { |
171 | foreach (@wait_how) { |
172 | $test = "cond_timedwait [$_]"; |
173 | threads->create(\&ctw, 5)->join; |
174 | $Base += 6; |
175 | } |
176 | }, 6*@wait_how, 90); |
a0e036c1 |
177 | |
178 | sub ctw($) { |
179 | my $to = shift; |
ee23bc3a |
180 | my $thr; |
181 | |
182 | { # -- begin lock scope; which lock to obtain? |
183 | $test =~ /twain/ ? lock($lock) : lock($cond); |
184 | ok(1,1, "$test: obtained initial lock"); |
185 | |
186 | $thr = threads->create(\&signaller); |
187 | my $ok = 0; |
188 | for ($test) { |
189 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
190 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; |
191 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; |
192 | die "$test: unknown test\n"; |
193 | } |
194 | ok(5,$ok, "$test: condition obtained"); |
195 | } # -- end lock scope |
a0e036c1 |
196 | |
a0e036c1 |
197 | $thr->join; |
ee23bc3a |
198 | ok(6,1, "$test: join completed"); |
a0e036c1 |
199 | } |
200 | |
201 | # - TEST cond_timedwait timeout |
202 | |
87c9b3a6 |
203 | forko( sub { |
204 | foreach (@wait_how) { |
205 | $test = "cond_timedwait pause, timeout [$_]"; |
206 | threads->create(\&ctw_fail, 3)->join; |
207 | $Base += 2; |
208 | } |
209 | }, 2*@wait_how, 90); |
a0e036c1 |
210 | |
87c9b3a6 |
211 | forko( sub { |
212 | foreach (@wait_how) { |
213 | $test = "cond_timedwait instant timeout [$_]"; |
214 | threads->create(\&ctw_fail, -60)->join; |
215 | $Base += 2; |
216 | } |
217 | }, 2*@wait_how, 90); |
a0e036c1 |
218 | |
219 | # cond_timedwait timeout (relative timeout) |
220 | sub ctw_fail { |
221 | my $to = shift; |
80b2a687 |
222 | if ($^O eq "hpux" && $Config{osvers} <= 10.20) { |
223 | # The lock obtaining would pass, but the wait will not. |
224 | ok(1,1, "$test: obtained initial lock"); |
225 | ok(2,0, "# SKIP see perl583delta"); |
7473853a |
226 | } else { |
80b2a687 |
227 | $test =~ /twain/ ? lock($lock) : lock($cond); |
228 | ok(1,1, "$test: obtained initial lock"); |
229 | my $ok; |
230 | for ($test) { |
7473853a |
231 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
232 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; |
233 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; |
234 | die "$test: unknown test\n"; |
80b2a687 |
235 | } |
236 | ok(2,!defined($ok), "$test: timeout"); |
a0e036c1 |
237 | } |
a0e036c1 |
238 | } |
239 | |
240 | } # -- SYNCH_SHARED block |
241 | |
242 | |
243 | # same as above, but with references to lock and cond vars |
244 | |
245 | SYNCH_REFS: { |
246 | my $test : shared; # simple|repeat|twain |
247 | |
248 | my $true_cond; share($true_cond); |
249 | my $true_lock; share($true_lock); |
250 | |
251 | my $cond = \$true_cond; |
252 | my $lock = \$true_lock; |
253 | |
254 | ok(1, 1, "Synchronization reference tests preparation"); |
255 | $Base += 1; |
256 | |
257 | sub signaller2 { |
258 | ok(2,1,"$test: child before lock"); |
259 | $test =~ /twain/ ? lock($lock) : lock($cond); |
260 | ok(3,1,"$test: child obtained lock"); |
261 | if ($test =~ 'twain') { |
262 | no warnings 'threads'; # lock var != cond var, so disable warnings |
263 | cond_signal($cond); |
264 | } else { |
265 | cond_signal($cond); |
266 | } |
267 | ok(4,1,"$test: child signalled condition"); |
268 | } |
269 | |
270 | # - TEST cond_wait |
87c9b3a6 |
271 | forko( sub { |
272 | foreach (@wait_how) { |
273 | $test = "cond_wait [$_]"; |
274 | threads->create(\&cw2)->join; |
275 | $Base += 6; |
276 | } |
277 | }, 6*@wait_how, 90); |
a0e036c1 |
278 | |
279 | sub cw2 { |
ee23bc3a |
280 | my $thr; |
281 | |
282 | { # -- begin lock scope; which lock to obtain? |
283 | $test =~ /twain/ ? lock($lock) : lock($cond); |
284 | ok(1,1, "$test: obtained initial lock"); |
285 | |
286 | $thr = threads->create(\&signaller2); |
287 | for ($test) { |
288 | cond_wait($cond), last if /simple/; |
289 | cond_wait($cond, $cond), last if /repeat/; |
290 | cond_wait($cond, $lock), last if /twain/; |
291 | die "$test: unknown test\n"; |
292 | } |
293 | ok(5,1, "$test: condition obtained"); |
294 | } # -- end lock scope |
a0e036c1 |
295 | |
a0e036c1 |
296 | $thr->join; |
ee23bc3a |
297 | ok(6,1, "$test: join completed"); |
a0e036c1 |
298 | } |
299 | |
300 | # - TEST cond_timedwait success |
301 | |
87c9b3a6 |
302 | forko( sub { |
303 | foreach (@wait_how) { |
304 | $test = "cond_timedwait [$_]"; |
305 | threads->create(\&ctw2, 5)->join; |
306 | $Base += 6; |
307 | } |
308 | }, 6*@wait_how, 90); |
a0e036c1 |
309 | |
310 | sub ctw2($) { |
311 | my $to = shift; |
ee23bc3a |
312 | my $thr; |
313 | |
314 | { # -- begin lock scope; which lock to obtain? |
315 | $test =~ /twain/ ? lock($lock) : lock($cond); |
316 | ok(1,1, "$test: obtained initial lock"); |
317 | |
318 | $thr = threads->create(\&signaller2); |
319 | my $ok = 0; |
320 | for ($test) { |
321 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
322 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; |
323 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; |
324 | die "$test: unknown test\n"; |
325 | } |
326 | ok(5,$ok, "$test: condition obtained"); |
327 | } # -- end lock scope |
a0e036c1 |
328 | |
a0e036c1 |
329 | $thr->join; |
ee23bc3a |
330 | ok(6,1, "$test: join completed"); |
a0e036c1 |
331 | } |
332 | |
333 | # - TEST cond_timedwait timeout |
334 | |
87c9b3a6 |
335 | forko( sub { |
336 | foreach (@wait_how) { |
337 | $test = "cond_timedwait pause, timeout [$_]"; |
338 | threads->create(\&ctw_fail2, 3)->join; |
339 | $Base += 2; |
340 | } |
341 | }, 2*@wait_how, 90); |
a0e036c1 |
342 | |
87c9b3a6 |
343 | forko( sub { |
344 | foreach (@wait_how) { |
345 | $test = "cond_timedwait instant timeout [$_]"; |
346 | threads->create(\&ctw_fail2, -60)->join; |
347 | $Base += 2; |
348 | } |
349 | }, 2*@wait_how, 90); |
a0e036c1 |
350 | |
351 | sub ctw_fail2 { |
352 | my $to = shift; |
353 | |
80b2a687 |
354 | if ($^O eq "hpux" && $Config{osvers} <= 10.20) { |
355 | # The lock obtaining would pass, but the wait will not. |
356 | ok(1,1, "$test: obtained initial lock"); |
357 | ok(2,0, "# SKIP see perl583delta"); |
7473853a |
358 | } else { |
80b2a687 |
359 | $test =~ /twain/ ? lock($lock) : lock($cond); |
360 | ok(1,1, "$test: obtained initial lock"); |
361 | my $ok; |
362 | for ($test) { |
7473853a |
363 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
364 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; |
365 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; |
366 | die "$test: unknown test\n"; |
80b2a687 |
367 | } |
368 | ok(2,!$ok, "$test: timeout"); |
a0e036c1 |
369 | } |
a0e036c1 |
370 | } |
371 | |
372 | } # -- SYNCH_REFS block |
373 | |
7473853a |
374 | # EOF |