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..91\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.
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.
63 *forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
64 ? sub (&$$) { my $code = shift; goto &$code; }
66 my ($code, $expected, $patience) = @_;
72 unless (defined($pid = open(CHLD, "-|"))) {
75 if (! $pid) { # Child -- run the test
76 alarm($patience || 60);
82 $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
83 #print "#forko: ($expected, $1) $_";
90 ok(++$test_num, 0, "missing test result: child status $?");
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 '\[$@%]$;\[$@%]'|);
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)
115 my $test : shared; # simple|repeat|twain
119 ok(1, 1, "Shared synchronization tests preparation");
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
132 ok(4,1,"$test: child signalled condition");
137 foreach (@wait_how) {
138 $test = "cond_wait [$_]";
139 threads->create(\&cw)->join;
145 # which lock to obtain?
146 $test =~ /twain/ ? lock($lock) : lock($cond);
147 ok(1,1, "$test: obtained initial lock");
149 my $thr = threads->create(\&signaller);
151 cond_wait($cond), last if /simple/;
152 cond_wait($cond, $cond), last if /repeat/;
153 cond_wait($cond, $lock), last if /twain/;
154 die "$test: unknown test\n";
157 ok(5,1, "$test: condition obtained");
160 # - TEST cond_timedwait success
163 foreach (@wait_how) {
164 $test = "cond_timedwait [$_]";
165 threads->create(\&ctw, 5)->join;
173 # which lock to obtain?
174 $test =~ /twain/ ? lock($lock) : lock($cond);
175 ok(1,1, "$test: obtained initial lock");
177 my $thr = threads->create(\&signaller);
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/;
183 die "$test: unknown test\n";
186 ok(5,$ok, "$test: condition obtained");
189 # - TEST cond_timedwait timeout
192 foreach (@wait_how) {
193 $test = "cond_timedwait pause, timeout [$_]";
194 threads->create(\&ctw_fail, 3)->join;
200 foreach (@wait_how) {
201 $test = "cond_timedwait instant timeout [$_]";
202 threads->create(\&ctw_fail, -60)->join;
207 # cond_timedwait timeout (relative timeout)
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");
215 $test =~ /twain/ ? lock($lock) : lock($cond);
216 ok(1,1, "$test: obtained initial lock");
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/;
222 die "$test: unknown test\n";
224 ok(2,!defined($ok), "$test: timeout");
228 } # -- SYNCH_SHARED block
231 # same as above, but with references to lock and cond vars
234 my $test : shared; # simple|repeat|twain
236 my $true_cond; share($true_cond);
237 my $true_lock; share($true_lock);
239 my $cond = \$true_cond;
240 my $lock = \$true_lock;
242 ok(1, 1, "Synchronization reference tests preparation");
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
255 ok(4,1,"$test: child signalled condition");
260 foreach (@wait_how) {
261 $test = "cond_wait [$_]";
262 threads->create(\&cw2)->join;
268 # which lock to obtain?
269 $test =~ /twain/ ? lock($lock) : lock($cond);
270 ok(1,1, "$test: obtained initial lock");
272 my $thr = threads->create(\&signaller2);
274 cond_wait($cond), last if /simple/;
275 cond_wait($cond, $cond), last if /repeat/;
276 cond_wait($cond, $lock), last if /twain/;
277 die "$test: unknown test\n";
280 ok(5,1, "$test: condition obtained");
283 # - TEST cond_timedwait success
286 foreach (@wait_how) {
287 $test = "cond_timedwait [$_]";
288 threads->create(\&ctw2, 5)->join;
296 # which lock to obtain?
297 $test =~ /twain/ ? lock($lock) : lock($cond);
298 ok(1,1, "$test: obtained initial lock");
300 my $thr = threads->create(\&signaller2);
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/;
306 die "$test: unknown test\n";
309 ok(5,$ok, "$test: condition obtained");
312 # - TEST cond_timedwait timeout
315 foreach (@wait_how) {
316 $test = "cond_timedwait pause, timeout [$_]";
317 threads->create(\&ctw_fail2, 3)->join;
323 foreach (@wait_how) {
324 $test = "cond_timedwait instant timeout [$_]";
325 threads->create(\&ctw_fail2, -60)->join;
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");
338 $test =~ /twain/ ? lock($lock) : lock($cond);
339 ok(1,1, "$test: obtained initial lock");
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/;
345 die "$test: unknown test\n";
347 ok(2,!$ok, "$test: timeout");
351 } # -- SYNCH_REFS block