-# cond_wait and cond_timedwait extended tests
-# adapted from cond.t
-
+use strict;
use warnings;
BEGIN {
- chdir 't' if -d 't';
- push @INC ,'../lib';
- require Config; import Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no threads\n";
- exit 0;
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ unshift @INC, '../lib';
+ }
+ use Config;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
-$|++;
-print "1..102\n";
-use strict;
-use threads;
-use threads::shared;
use ExtUtils::testlib;
my $Base = 0;
-
sub ok {
- my ($offset, $bool, $text) = @_;
- my $not = '';
- $not = "not " unless $bool;
- print "${not}ok " . ($Base + $offset) . " - $text\n";
+ my ($id, $ok, $name) = @_;
+ $id += $Base;
+
+ # You have to do it this way or VMS will get confused.
+ if ($ok) {
+ print("ok $id - $name\n");
+ } else {
+ print("not ok $id - $name\n");
+ printf("# Failed test at line %d\n", (caller)[2]);
+ }
+
+ return ($ok);
}
+BEGIN {
+ $| = 1;
+ print("1..91\n"); ### Number of tests that will be run ###
+};
+
+use threads;
+use threads::shared;
+ok(1, 1, 'Loaded');
+$Base++;
+
+### Start of Testing ###
+
+# cond_wait and cond_timedwait extended tests adapted from cond.t
+
# The two skips later on in these tests refer to this quote from the
# pod/perl583delta.pod:
#
# =head1 Platform Specific Problems
-#
+#
# The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
# and HP-UX 10.20 due to bugs in their threading implementations.
# RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
# and consider upgrading their glibc.
+
sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
# stock RH9 glibc/NPTL) or from our own errors, we run tests
# in separately forked and alarmed processes.
my $bump = $expected;
- $patience ||= 60;
-
unless (defined($pid = open(CHLD, "-|"))) {
die "fork: $!\n";
}
if (! $pid) { # Child -- run the test
- $patience ||= 60;
- alarm $patience;
+ alarm($patience || 60);
&$code;
exit;
}
close(CHLD);
while ($expected--) {
- $test_num++;
- print "not ok $test_num - child status $?\n";
+ ok(++$test_num, 0, "missing test result: child status $?");
}
$Base += $bump;
-
};
+
# - TEST basics
ok(1, defined &cond_wait, "cond_wait() present");
my $cond : shared;
my $lock : shared;
- print "# testing my \$var : shared\n";
ok(1, 1, "Shared synchronization tests preparation");
$Base += 1;
foreach (@wait_how) {
$test = "cond_wait [$_]";
threads->create(\&cw)->join;
- $Base += 6;
+ $Base += 5;
}
- }, 6*@wait_how, 90);
+ }, 5*@wait_how, 90);
sub cw {
- my $thr;
-
- { # -- begin lock scope; which lock to obtain?
+ # which lock to obtain?
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
- $thr = threads->create(\&signaller);
+ my $thr = threads->create(\&signaller);
for ($test) {
cond_wait($cond), last if /simple/;
cond_wait($cond, $cond), last if /repeat/;
cond_wait($cond, $lock), last if /twain/;
- die "$test: unknown test\n";
+ die "$test: unknown test\n";
}
+ $thr->join;
ok(5,1, "$test: condition obtained");
- } # -- end lock scope
-
- $thr->join;
- ok(6,1, "$test: join completed");
}
# - TEST cond_timedwait success
foreach (@wait_how) {
$test = "cond_timedwait [$_]";
threads->create(\&ctw, 5)->join;
- $Base += 6;
+ $Base += 5;
}
- }, 6*@wait_how, 90);
+ }, 5*@wait_how, 90);
sub ctw($) {
- my $to = shift;
- my $thr;
+ my $to = shift;
- { # -- begin lock scope; which lock to obtain?
+ # which lock to obtain?
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
- $thr = threads->create(\&signaller);
+ my $thr = threads->create(\&signaller);
my $ok = 0;
for ($test) {
$ok=cond_timedwait($cond, time() + $to), last if /simple/;
$ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
$ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
- die "$test: unknown test\n";
+ die "$test: unknown test\n";
}
+ $thr->join;
ok(5,$ok, "$test: condition obtained");
- } # -- end lock scope
-
- $thr->join;
- ok(6,1, "$test: join completed");
}
# - TEST cond_timedwait timeout
# cond_timedwait timeout (relative timeout)
sub ctw_fail {
my $to = shift;
-
if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
# The lock obtaining would pass, but the wait will not.
ok(1,1, "$test: obtained initial lock");
ok(2,0, "# SKIP see perl583delta");
- }
- else {
+ } else {
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
my $ok;
for ($test) {
- $ok=cond_timedwait($cond, time() + $to), last if /simple/;
- $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
- $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
- die "$test: unknown test\n";
+ $ok=cond_timedwait($cond, time() + $to), last if /simple/;
+ $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
+ $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
+ die "$test: unknown test\n";
}
ok(2,!defined($ok), "$test: timeout");
}
SYNCH_REFS: {
my $test : shared; # simple|repeat|twain
-
+
my $true_cond; share($true_cond);
my $true_lock; share($true_lock);
my $cond = \$true_cond;
my $lock = \$true_lock;
- print "# testing reference to shared(\$var)\n";
ok(1, 1, "Synchronization reference tests preparation");
$Base += 1;
foreach (@wait_how) {
$test = "cond_wait [$_]";
threads->create(\&cw2)->join;
- $Base += 6;
+ $Base += 5;
}
- }, 6*@wait_how, 90);
+ }, 5*@wait_how, 90);
sub cw2 {
- my $thr;
-
- { # -- begin lock scope; which lock to obtain?
+ # which lock to obtain?
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
- $thr = threads->create(\&signaller2);
+ my $thr = threads->create(\&signaller2);
for ($test) {
cond_wait($cond), last if /simple/;
cond_wait($cond, $cond), last if /repeat/;
cond_wait($cond, $lock), last if /twain/;
- die "$test: unknown test\n";
+ die "$test: unknown test\n";
}
+ $thr->join;
ok(5,1, "$test: condition obtained");
- } # -- end lock scope
-
- $thr->join;
- ok(6,1, "$test: join completed");
}
# - TEST cond_timedwait success
foreach (@wait_how) {
$test = "cond_timedwait [$_]";
threads->create(\&ctw2, 5)->join;
- $Base += 6;
+ $Base += 5;
}
- }, 6*@wait_how, 90);
+ }, 5*@wait_how, 90);
sub ctw2($) {
- my $to = shift;
- my $thr;
+ my $to = shift;
- { # -- begin lock scope; which lock to obtain?
+ # which lock to obtain?
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
- $thr = threads->create(\&signaller2);
+ my $thr = threads->create(\&signaller2);
my $ok = 0;
for ($test) {
$ok=cond_timedwait($cond, time() + $to), last if /simple/;
$ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
$ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
- die "$test: unknown test\n";
+ die "$test: unknown test\n";
}
+ $thr->join;
ok(5,$ok, "$test: condition obtained");
- } # -- end lock scope
-
- $thr->join;
- ok(6,1, "$test: join completed");
}
# - TEST cond_timedwait timeout
# The lock obtaining would pass, but the wait will not.
ok(1,1, "$test: obtained initial lock");
ok(2,0, "# SKIP see perl583delta");
- }
- else {
+ } else {
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
my $ok;
for ($test) {
- $ok=cond_timedwait($cond, time() + $to), last if /simple/;
- $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
- $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
- die "$test: unknown test\n";
+ $ok=cond_timedwait($cond, time() + $to), last if /simple/;
+ $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
+ $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
+ die "$test: unknown test\n";
}
ok(2,!$ok, "$test: timeout");
}
} # -- SYNCH_REFS block
+exit(0);
+
+# EOF
projects / p5sagit/p5-mst-13.2.git / blobdiff