5 if ($ENV{'PERL_CORE'}){
7 unshift @INC, '../lib';
10 if (! $Config{'useithreads'}) {
11 print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
16 use ExtUtils::testlib;
20 my ($id, $ok, $name) = @_;
23 # You have to do it this way or VMS will get confused.
25 print("ok $id - $name\n");
27 print("not ok $id - $name\n");
28 printf("# Failed test at line %d\n", (caller)[2]);
36 print("1..103\n"); ### Number of tests that will be run ###
44 ### Start of Testing ###
46 # cond_wait and cond_timedwait extended tests adapted from cond.t
48 # The two skips later on in these tests refer to this quote from the
49 # pod/perl583delta.pod:
51 # =head1 Platform Specific Problems
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.
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.
62 *forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
63 ? sub (&$$) { my $code = shift; goto &$code; }
65 my ($code, $expected, $patience) = @_;
73 unless (defined($pid = open(CHLD, "-|"))) {
76 if (! $pid) { # Child -- run the test
84 $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
85 #print "#forko: ($expected, $1) $_";
93 print "not ok $test_num - child status $?\n";
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 '\[$@%]$;\[$@%]'|);
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)
118 my $test : shared; # simple|repeat|twain
122 ok(1, 1, "Shared synchronization tests preparation");
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
135 ok(4,1,"$test: child signalled condition");
140 foreach (@wait_how) {
141 $test = "cond_wait [$_]";
142 threads->create(\&cw)->join;
150 { # -- begin lock scope; which lock to obtain?
151 $test =~ /twain/ ? lock($lock) : lock($cond);
152 ok(1,1, "$test: obtained initial lock");
154 $thr = threads->create(\&signaller);
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";
161 ok(5,1, "$test: condition obtained");
162 } # -- end lock scope
165 ok(6,1, "$test: join completed");
168 # - TEST cond_timedwait success
171 foreach (@wait_how) {
172 $test = "cond_timedwait [$_]";
173 threads->create(\&ctw, 5)->join;
182 { # -- begin lock scope; which lock to obtain?
183 $test =~ /twain/ ? lock($lock) : lock($cond);
184 ok(1,1, "$test: obtained initial lock");
186 $thr = threads->create(\&signaller);
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";
194 ok(5,$ok, "$test: condition obtained");
195 } # -- end lock scope
198 ok(6,1, "$test: join completed");
201 # - TEST cond_timedwait timeout
204 foreach (@wait_how) {
205 $test = "cond_timedwait pause, timeout [$_]";
206 threads->create(\&ctw_fail, 3)->join;
212 foreach (@wait_how) {
213 $test = "cond_timedwait instant timeout [$_]";
214 threads->create(\&ctw_fail, -60)->join;
219 # cond_timedwait timeout (relative timeout)
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");
227 $test =~ /twain/ ? lock($lock) : lock($cond);
228 ok(1,1, "$test: obtained initial lock");
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";
236 ok(2,!defined($ok), "$test: timeout");
240 } # -- SYNCH_SHARED block
243 # same as above, but with references to lock and cond vars
246 my $test : shared; # simple|repeat|twain
248 my $true_cond; share($true_cond);
249 my $true_lock; share($true_lock);
251 my $cond = \$true_cond;
252 my $lock = \$true_lock;
254 ok(1, 1, "Synchronization reference tests preparation");
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
267 ok(4,1,"$test: child signalled condition");
272 foreach (@wait_how) {
273 $test = "cond_wait [$_]";
274 threads->create(\&cw2)->join;
282 { # -- begin lock scope; which lock to obtain?
283 $test =~ /twain/ ? lock($lock) : lock($cond);
284 ok(1,1, "$test: obtained initial lock");
286 $thr = threads->create(\&signaller2);
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";
293 ok(5,1, "$test: condition obtained");
294 } # -- end lock scope
297 ok(6,1, "$test: join completed");
300 # - TEST cond_timedwait success
303 foreach (@wait_how) {
304 $test = "cond_timedwait [$_]";
305 threads->create(\&ctw2, 5)->join;
314 { # -- begin lock scope; which lock to obtain?
315 $test =~ /twain/ ? lock($lock) : lock($cond);
316 ok(1,1, "$test: obtained initial lock");
318 $thr = threads->create(\&signaller2);
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";
326 ok(5,$ok, "$test: condition obtained");
327 } # -- end lock scope
330 ok(6,1, "$test: join completed");
333 # - TEST cond_timedwait timeout
336 foreach (@wait_how) {
337 $test = "cond_timedwait pause, timeout [$_]";
338 threads->create(\&ctw_fail2, 3)->join;
344 foreach (@wait_how) {
345 $test = "cond_timedwait instant timeout [$_]";
346 threads->create(\&ctw_fail2, -60)->join;
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");
359 $test =~ /twain/ ? lock($lock) : lock($cond);
360 ok(1,1, "$test: obtained initial lock");
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";
368 ok(2,!$ok, "$test: timeout");
372 } # -- SYNCH_REFS block