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