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