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..63\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.
67 sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
68 # stock RH9 glibc/NPTL) or from our own errors, we run tests
69 # in separately forked and alarmed processes.
71 *forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
72 ? sub (&$$) { my $code = shift; goto &$code; }
74 my ($code, $expected, $patience) = @_;
82 unless (defined($pid = open(CHLD, "-|"))) {
85 if (! $pid) { # Child -- run the test
93 $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
94 #print "#forko: ($expected, $1) $_";
100 while ($expected--) {
102 print "not ok $test_num - child status $?\n";
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");
138 # - TEST cond_timedwait success
141 foreach (@wait_how) {
142 $test = "cond_timedwait [$_]";
143 threads->create(\&ctw, 0.05)->join;
152 { # -- begin lock scope; which lock to obtain?
153 $test =~ /twain/ ? lock($lock) : lock($cond);
154 ok(1,1, "$test: obtained initial lock");
156 $thr = threads->create(\&signaller);
159 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
160 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
161 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
162 die "$test: unknown test\n";
164 ok(5,$ok, "$test: condition obtained");
165 } # -- end lock scope
168 ok(6,1, "$test: join completed");
171 # - TEST cond_timedwait timeout
174 foreach (@wait_how) {
175 $test = "cond_timedwait pause, timeout [$_]";
176 threads->create(\&ctw_fail, 0.3)->join;
182 foreach (@wait_how) {
183 $test = "cond_timedwait instant timeout [$_]";
184 threads->create(\&ctw_fail, -0.60)->join;
189 # cond_timedwait timeout (relative timeout)
192 if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
193 # The lock obtaining would pass, but the wait will not.
194 ok(1,1, "$test: obtained initial lock");
195 ok(2,0, "# SKIP see perl583delta");
197 $test =~ /twain/ ? lock($lock) : lock($cond);
198 ok(1,1, "$test: obtained initial lock");
202 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
203 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
204 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
205 die "$test: unknown test\n";
207 $delta = time() - $delta;
208 ok(2, ! defined($ok), "$test: timeout");
210 if (($to > 0) && ($^O ne 'os2')) {
211 # Timing tests can be problematic
212 if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
213 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
219 } # -- SYNCH_SHARED block
222 # same as above, but with references to lock and cond vars
225 my $test : shared; # simple|repeat|twain
227 my $true_cond; share($true_cond);
228 my $true_lock; share($true_lock);
230 my $cond = \$true_cond;
231 my $lock = \$true_lock;
233 ok(1, 1, "Synchronization reference tests preparation");
237 ok(2,1,"$test: child before lock");
238 $test =~ /twain/ ? lock($lock) : lock($cond);
239 ok(3,1,"$test: child obtained lock");
240 if ($test =~ 'twain') {
241 no warnings 'threads'; # lock var != cond var, so disable warnings
246 ok(4,1,"$test: child signalled condition");
249 # - TEST cond_timedwait success
252 foreach (@wait_how) {
253 $test = "cond_timedwait [$_]";
254 threads->create(\&ctw2, 0.05)->join;
263 { # -- begin lock scope; which lock to obtain?
264 $test =~ /twain/ ? lock($lock) : lock($cond);
265 ok(1,1, "$test: obtained initial lock");
267 $thr = threads->create(\&signaller2);
270 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
271 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
272 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
273 die "$test: unknown test\n";
275 ok(5,$ok, "$test: condition obtained");
276 } # -- end lock scope
279 ok(6,1, "$test: join completed");
282 # - TEST cond_timedwait timeout
285 foreach (@wait_how) {
286 $test = "cond_timedwait pause, timeout [$_]";
287 threads->create(\&ctw_fail2, 0.3)->join;
293 foreach (@wait_how) {
294 $test = "cond_timedwait instant timeout [$_]";
295 threads->create(\&ctw_fail2, -0.60)->join;
303 if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
304 # The lock obtaining would pass, but the wait will not.
305 ok(1,1, "$test: obtained initial lock");
306 ok(2,0, "# SKIP see perl583delta");
308 $test =~ /twain/ ? lock($lock) : lock($cond);
309 ok(1,1, "$test: obtained initial lock");
313 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
314 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
315 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
316 die "$test: unknown test\n";
318 $delta = time() - $delta;
319 ok(2, ! $ok, "$test: timeout");
321 if (($to > 0) && ($^O ne 'os2')) {
322 # Timing tests can be problematic
323 if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
324 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
330 } # -- SYNCH_REFS block