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 import Time::HiRes qw(time);
19 print("1..0 # Skip: Time::HiRes not available.\n");
24 use ExtUtils::testlib;
28 my ($id, $ok, $name) = @_;
31 # You have to do it this way or VMS will get confused.
33 print("ok $id - $name\n");
35 print("not ok $id - $name\n");
36 printf("# Failed test at line %d\n", (caller)[2]);
44 print("1..57\n"); ### Number of tests that will be run ###
53 ### Start of Testing ###
55 # subsecond cond_timedwait extended tests adapted from wait.t
57 # The two skips later on in these tests refer to this quote from the
58 # pod/perl583delta.pod:
60 # =head1 Platform Specific Problems
62 # The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
63 # and HP-UX 10.20 due to bugs in their threading implementations.
64 # RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
65 # and consider upgrading their glibc.
68 sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
69 # stock RH9 glibc/NPTL) or from our own errors, we run tests
70 # in separately forked and alarmed processes.
72 *forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
73 ? sub (&$$) { my $code = shift; goto &$code; }
75 my ($code, $expected, $patience) = @_;
81 unless (defined($pid = open(CHLD, "-|"))) {
84 if (! $pid) { # Child -- run the test
85 alarm($patience || 60);
91 $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
92 #print "#forko: ($expected, $1) $_";
99 ok(++$test_num, 0, "missing test result: child status $?");
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");
135 # - TEST cond_timedwait success
138 foreach (@wait_how) {
139 $test = "cond_timedwait [$_]";
140 threads->create(\&ctw, 0.05)->join;
148 # which lock to obtain?
149 $test =~ /twain/ ? lock($lock) : lock($cond);
150 ok(1,1, "$test: obtained initial lock");
152 my $thr = threads->create(\&signaller);
155 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
156 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
157 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
158 die "$test: unknown test\n";
161 ok(5,$ok, "$test: condition obtained");
164 # - TEST cond_timedwait timeout
167 foreach (@wait_how) {
168 $test = "cond_timedwait pause, timeout [$_]";
169 threads->create(\&ctw_fail, 0.3)->join;
175 foreach (@wait_how) {
176 $test = "cond_timedwait instant timeout [$_]";
177 threads->create(\&ctw_fail, -0.60)->join;
182 # cond_timedwait timeout (relative timeout)
185 if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
186 # The lock obtaining would pass, but the wait will not.
187 ok(1,1, "$test: obtained initial lock");
188 ok(2,0, "# SKIP see perl583delta");
190 $test =~ /twain/ ? lock($lock) : lock($cond);
191 ok(1,1, "$test: obtained initial lock");
195 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
196 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
197 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
198 die "$test: unknown test\n";
200 $delta = time() - $delta;
201 ok(2, ! defined($ok), "$test: timeout");
203 if (($to > 0) && ($^O ne 'os2')) {
204 # Timing tests can be problematic
205 if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
206 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
212 } # -- SYNCH_SHARED block
215 # same as above, but with references to lock and cond vars
218 my $test : shared; # simple|repeat|twain
220 my $true_cond; share($true_cond);
221 my $true_lock; share($true_lock);
223 my $cond = \$true_cond;
224 my $lock = \$true_lock;
226 ok(1, 1, "Synchronization reference tests preparation");
230 ok(2,1,"$test: child before lock");
231 $test =~ /twain/ ? lock($lock) : lock($cond);
232 ok(3,1,"$test: child obtained lock");
233 if ($test =~ 'twain') {
234 no warnings 'threads'; # lock var != cond var, so disable warnings
239 ok(4,1,"$test: child signalled condition");
242 # - TEST cond_timedwait success
245 foreach (@wait_how) {
246 $test = "cond_timedwait [$_]";
247 threads->create(\&ctw2, 0.05)->join;
255 # which lock to obtain?
256 $test =~ /twain/ ? lock($lock) : lock($cond);
257 ok(1,1, "$test: obtained initial lock");
259 my $thr = threads->create(\&signaller2);
262 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
263 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
264 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
265 die "$test: unknown test\n";
268 ok(5,$ok, "$test: condition obtained");
271 # - TEST cond_timedwait timeout
274 foreach (@wait_how) {
275 $test = "cond_timedwait pause, timeout [$_]";
276 threads->create(\&ctw_fail2, 0.3)->join;
282 foreach (@wait_how) {
283 $test = "cond_timedwait instant timeout [$_]";
284 threads->create(\&ctw_fail2, -0.60)->join;
292 if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
293 # The lock obtaining would pass, but the wait will not.
294 ok(1,1, "$test: obtained initial lock");
295 ok(2,0, "# SKIP see perl583delta");
297 $test =~ /twain/ ? lock($lock) : lock($cond);
298 ok(1,1, "$test: obtained initial lock");
302 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
303 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
304 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
305 die "$test: unknown test\n";
307 $delta = time() - $delta;
308 ok(2, ! $ok, "$test: timeout");
310 if (($to > 0) && ($^O ne 'os2')) {
311 # Timing tests can be problematic
312 if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
313 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
319 } # -- SYNCH_REFS block