use strict;
use warnings;
+use Config;
BEGIN {
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);
use ExtUtils::testlib;
-my $Base = 0;
+### Self-destruct timer child process
+my $TIMEOUT = 600;
+my $timer_pid;
+
+if ($Config{'d_fork'}) {
+ $timer_pid = fork();
+ if (defined($timer_pid) && ($timer_pid == 0)) {
+ # Child process
+ my $ppid = getppid();
+
+ # Sleep for timeout period
+ sleep($TIMEOUT - 2); # Workaround for perlbug #49073
+ sleep(2); # Wait for parent to exit
+
+ # Kill parent if it still exists
+ kill('KILL', $ppid) if (kill(0, $ppid));
+ exit(0);
+ }
+ # Parent will kill this process if tests finish on time
+}
+
+
sub ok {
my ($id, $ok, $name) = @_;
- $id += $Base;
# You have to do it this way or VMS will get confused.
if ($ok) {
use threads;
use threads::shared;
-ok(1, 1, 'Loaded');
-$Base++;
+
+my $TEST = 1;
+ok($TEST++, 1, 'Loaded');
+
### Start of Testing ###
# 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.
+# - TEST basics
-*forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
-? sub (&$$) { my $code = shift; goto &$code; }
-: sub (&$$) {
- my ($code, $expected, $patience) = @_;
- my ($test_num, $pid);
- local *CHLD;
+ok($TEST++, defined &cond_wait, "cond_wait() present");
+ok($TEST++, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'),
+ q/cond_wait() prototype '\[$@%];\[$@%]'/);
+ok($TEST++, defined &cond_timedwait, "cond_timedwait() present");
+ok($TEST++, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'),
+ q/cond_timedwait() prototype '\[$@%]$;\[$@%]'/);
- my $bump = $expected;
- unless (defined($pid = open(CHLD, "-|"))) {
- die "fork: $!\n";
- }
- if (! $pid) { # Child -- run the test
- alarm($patience || 60);
- &$code;
- exit;
- }
+my @wait_how = (
+ "simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c)
+ "repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
+ "twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
+);
- while (<CHLD>) {
- $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
- #print "#forko: ($expected, $1) $_";
- print;
- }
- close(CHLD);
+SYNC_SHARED: {
+ my $test_type :shared; # simple|repeat|twain
- while ($expected--) {
- ok(++$test_num, 0, "missing test result: child status $?");
- }
+ my $cond :shared;
+ my $lock :shared;
- $Base += $bump;
-};
+ ok($TEST++, 1, "Shared synchronization tests preparation");
+ sub signaller
+ {
+ my $testno = $_[0];
-# - TEST basics
+ ok($testno++, 1, "$test_type: child before lock");
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testno++, 1, "$test_type: child obtained lock");
-ok(1, defined &cond_wait, "cond_wait() present");
-ok(2, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'),
- q|cond_wait() prototype '\[$@%];\[$@%]'|);
-ok(3, defined &cond_timedwait, "cond_timedwait() present");
-ok(4, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'),
- q|cond_timedwait() prototype '\[$@%]$;\[$@%]'|);
+ if ($test_type =~ 'twain') {
+ no warnings 'threads'; # lock var != cond var, so disable warnings
+ cond_signal($cond);
+ } else {
+ cond_signal($cond);
+ }
+ ok($testno++, 1, "$test_type: child signalled condition");
-$Base += 4;
+ return($testno);
+ }
-my @wait_how = (
- "simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c)
- "repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
- "twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
-);
+ # - TEST cond_wait
-SYNC_SHARED: {
- my $test : shared; # simple|repeat|twain
- my $cond : shared;
- my $lock : shared;
-
- ok(1, 1, "Shared synchronization tests preparation");
- $Base += 1;
-
- sub signaller {
- ok(2,1,"$test: child before lock");
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(3,1,"$test: child obtained lock");
- if ($test =~ 'twain') {
- no warnings 'threads'; # lock var != cond var, so disable warnings
- cond_signal($cond);
- } else {
- cond_signal($cond);
+ sub cw
+ {
+ my ($testnum, $to) = @_;
+
+ # Which lock to obtain?
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+
+ my $thr = threads->create(\&signaller, $testnum);
+ for ($test_type) {
+ cond_wait($cond), last if /simple/;
+ cond_wait($cond, $cond), last if /repeat/;
+ cond_wait($cond, $lock), last if /twain/;
+ die "$test_type: unknown test\n";
+ }
+ $testnum = $thr->join();
+ ok($testnum++, 1, "$test_type: condition obtained");
+
+ return ($testnum);
}
- ok(4,1,"$test: child signalled condition");
- }
- # - TEST cond_wait
- forko( sub {
foreach (@wait_how) {
- $test = "cond_wait [$_]";
- threads->create(\&cw)->join;
- $Base += 5;
+ $test_type = "cond_wait [$_]";
+ my $thr = threads->create(\&cw, $TEST);
+ $TEST = $thr->join();
}
- }, 5*@wait_how, 90);
-
- sub cw {
- # which lock to obtain?
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
-
- 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";
- }
- $thr->join;
- ok(5,1, "$test: condition obtained");
- }
-
- # - TEST cond_timedwait success
-
- forko( sub {
- foreach (@wait_how) {
- $test = "cond_timedwait [$_]";
- threads->create(\&ctw, 5)->join;
- $Base += 5;
+
+ # - TEST cond_timedwait success
+
+ sub ctw_ok
+ {
+ my ($testnum, $to) = @_;
+
+ # Which lock to obtain?
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+
+ my $thr = threads->create(\&signaller, $testnum);
+ my $ok = 0;
+ for ($test_type) {
+ $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_type: unknown test\n";
+ }
+ $testnum = $thr->join();
+ ok($testnum++, $ok, "$test_type: condition obtained");
+
+ return ($testnum);
}
- }, 5*@wait_how, 90);
-
- sub ctw($) {
- my $to = shift;
-
- # which lock to obtain?
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
-
- 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";
- }
- $thr->join;
- ok(5,$ok, "$test: condition obtained");
- }
-
- # - TEST cond_timedwait timeout
-
- forko( sub {
+
foreach (@wait_how) {
- $test = "cond_timedwait pause, timeout [$_]";
- threads->create(\&ctw_fail, 3)->join;
- $Base += 2;
+ $test_type = "cond_timedwait [$_]";
+ my $thr = threads->create(\&ctw_ok, $TEST, 5);
+ $TEST = $thr->join();
+ }
+
+ # - TEST cond_timedwait timeout
+
+ sub ctw_fail
+ {
+ my ($testnum, $to) = @_;
+
+ if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
+ # The lock obtaining would pass, but the wait will not.
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+ ok($testnum++, 0, "# SKIP see perl583delta");
+
+ } else {
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+ my $ok;
+ for ($test_type) {
+ $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_type: unknown test\n";
+ }
+ ok($testnum++, ! defined($ok), "$test_type: timeout");
+ }
+
+ return ($testnum);
}
- }, 2*@wait_how, 90);
- forko( sub {
foreach (@wait_how) {
- $test = "cond_timedwait instant timeout [$_]";
- threads->create(\&ctw_fail, -60)->join;
- $Base += 2;
+ $test_type = "cond_timedwait pause, timeout [$_]";
+ my $thr = threads->create(\&ctw_fail, $TEST, 3);
+ $TEST = $thr->join();
}
- }, 2*@wait_how, 90);
-
- # 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 {
- $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(2,!defined($ok), "$test: timeout");
+
+ foreach (@wait_how) {
+ $test_type = "cond_timedwait instant timeout [$_]";
+ my $thr = threads->create(\&ctw_fail, $TEST, -60);
+ $TEST = $thr->join();
}
- }
} # -- SYNCH_SHARED block
# same as above, but with references to lock and cond vars
SYNCH_REFS: {
- my $test : shared; # simple|repeat|twain
+ my $test_type :shared; # simple|repeat|twain
- my $true_cond; share($true_cond);
- my $true_lock; share($true_lock);
+ my $true_cond :shared;
+ my $true_lock :shared;
- my $cond = \$true_cond;
- my $lock = \$true_lock;
+ my $cond = \$true_cond;
+ my $lock = \$true_lock;
- ok(1, 1, "Synchronization reference tests preparation");
- $Base += 1;
+ ok($TEST++, 1, "Synchronization reference tests preparation");
- sub signaller2 {
- ok(2,1,"$test: child before lock");
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(3,1,"$test: child obtained lock");
- if ($test =~ 'twain') {
- no warnings 'threads'; # lock var != cond var, so disable warnings
- cond_signal($cond);
- } else {
- cond_signal($cond);
+ sub signaller2
+ {
+ my $testno = $_[0];
+
+ ok($testno++, 1, "$test_type: child before lock");
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testno++, 1, "$test_type: child obtained lock");
+
+ if ($test_type =~ 'twain') {
+ no warnings 'threads'; # lock var != cond var, so disable warnings
+ cond_signal($cond);
+ } else {
+ cond_signal($cond);
+ }
+ ok($testno++, 1, "$test_type: child signalled condition");
+
+ return($testno);
}
- ok(4,1,"$test: child signalled condition");
- }
- # - TEST cond_wait
- forko( sub {
- foreach (@wait_how) {
- $test = "cond_wait [$_]";
- threads->create(\&cw2)->join;
- $Base += 5;
+ # - TEST cond_wait
+
+ sub cw2
+ {
+ my ($testnum, $to) = @_;
+
+ # Which lock to obtain?
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+
+ my $thr = threads->create(\&signaller2, $testnum);
+ for ($test_type) {
+ cond_wait($cond), last if /simple/;
+ cond_wait($cond, $cond), last if /repeat/;
+ cond_wait($cond, $lock), last if /twain/;
+ die "$test_type: unknown test\n";
+ }
+ $testnum = $thr->join();
+ ok($testnum++, 1, "$test_type: condition obtained");
+
+ return ($testnum);
}
- }, 5*@wait_how, 90);
-
- sub cw2 {
- # which lock to obtain?
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
-
- 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";
- }
- $thr->join;
- ok(5,1, "$test: condition obtained");
- }
-
- # - TEST cond_timedwait success
-
- forko( sub {
+
foreach (@wait_how) {
- $test = "cond_timedwait [$_]";
- threads->create(\&ctw2, 5)->join;
- $Base += 5;
+ $test_type = "cond_wait [$_]";
+ my $thr = threads->create(\&cw2, $TEST);
+ $TEST = $thr->join();
}
- }, 5*@wait_how, 90);
-
- sub ctw2($) {
- my $to = shift;
-
- # which lock to obtain?
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
-
- 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";
- }
- $thr->join;
- ok(5,$ok, "$test: condition obtained");
- }
-
- # - TEST cond_timedwait timeout
-
- forko( sub {
- foreach (@wait_how) {
- $test = "cond_timedwait pause, timeout [$_]";
- threads->create(\&ctw_fail2, 3)->join;
- $Base += 2;
+
+ # - TEST cond_timedwait success
+
+ sub ctw_ok2
+ {
+ my ($testnum, $to) = @_;
+
+ # Which lock to obtain?
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+
+ my $thr = threads->create(\&signaller2, $testnum);
+ my $ok = 0;
+ for ($test_type) {
+ $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_type: unknown test\n";
+ }
+ $testnum = $thr->join();
+ ok($testnum++, $ok, "$test_type: condition obtained");
+
+ return ($testnum);
}
- }, 2*@wait_how, 90);
- forko( sub {
foreach (@wait_how) {
- $test = "cond_timedwait instant timeout [$_]";
- threads->create(\&ctw_fail2, -60)->join;
- $Base += 2;
+ $test_type = "cond_timedwait [$_]";
+ my $thr = threads->create(\&ctw_ok2, $TEST, 5);
+ $TEST = $thr->join();
}
- }, 2*@wait_how, 90);
- sub ctw_fail2 {
- my $to = shift;
+ # - TEST cond_timedwait timeout
+
+ sub ctw_fail2
+ {
+ my ($testnum, $to) = @_;
+
+ if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
+ # The lock obtaining would pass, but the wait will not.
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+ ok($testnum++, 0, "# SKIP see perl583delta");
+
+ } else {
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+ my $ok;
+ for ($test_type) {
+ $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_type: unknown test\n";
+ }
+ ok($testnum++, ! defined($ok), "$test_type: timeout");
+ }
+
+ return ($testnum);
+ }
- 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 {
- $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(2,!$ok, "$test: timeout");
+ foreach (@wait_how) {
+ $test_type = "cond_timedwait pause, timeout [$_]";
+ my $thr = threads->create(\&ctw_fail2, $TEST, 3);
+ $TEST = $thr->join();
+ }
+
+ foreach (@wait_how) {
+ $test_type = "cond_timedwait instant timeout [$_]";
+ my $thr = threads->create(\&ctw_fail2, $TEST, -60);
+ $TEST = $thr->join();
}
- }
} # -- SYNCH_REFS block
+# Kill timer process
+if ($timer_pid && kill(0, $timer_pid)) {
+ kill('KILL', $timer_pid);
+}
+
+# Done
exit(0);
# EOF
use strict;
use warnings;
+use Config;
BEGIN {
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);
use ExtUtils::testlib;
-my $Base = 0;
+### Self-destruct timer child process
+my $TIMEOUT = 60;
+my $timer_pid;
+
+if ($Config{'d_fork'}) {
+ $timer_pid = fork();
+ if (defined($timer_pid) && ($timer_pid == 0)) {
+ # Child process
+ my $ppid = getppid();
+
+ # Sleep for timeout period
+ sleep($TIMEOUT - 2); # Workaround for perlbug #49073
+ sleep(2); # Wait for parent to exit
+
+ # Kill parent if it still exists
+ kill('KILL', $ppid) if (kill(0, $ppid));
+ exit(0);
+ }
+ # Parent will kill this process if tests finish on time
+}
+
+
sub ok {
my ($id, $ok, $name) = @_;
- $id += $Base;
# You have to do it this way or VMS will get confused.
if ($ok) {
use threads;
use threads::shared;
-ok(1, 1, 'Loaded');
-$Base++;
+my $TEST = 1;
+ok($TEST++, 1, 'Loaded');
+
### Start of Testing ###
# 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.
-
-*forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
-? sub (&$$) { my $code = shift; goto &$code; }
-: sub (&$$) {
- my ($code, $expected, $patience) = @_;
- my ($test_num, $pid);
- local *CHLD;
+# - TEST basics
- my $bump = $expected;
+my @wait_how = (
+ "simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c)
+ "repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
+ "twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
+);
- unless (defined($pid = open(CHLD, "-|"))) {
- die "fork: $!\n";
- }
- if (! $pid) { # Child -- run the test
- alarm($patience || 60);
- &$code;
- exit;
- }
- while (<CHLD>) {
- $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
- #print "#forko: ($expected, $1) $_";
- print;
- }
+SYNC_SHARED: {
+ my $test_type :shared; # simple|repeat|twain
- close(CHLD);
+ my $cond :shared;
+ my $lock :shared;
- while ($expected--) {
- ok(++$test_num, 0, "missing test result: child status $?");
- }
+ ok($TEST++, 1, "Shared synchronization tests preparation");
- $Base += $bump;
-};
+ # - TEST cond_timedwait success
+ sub signaller
+ {
+ my $testno = $_[0];
-# - TEST basics
+ ok($testno++, 1, "$test_type: child before lock");
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testno++, 1, "$test_type: child obtained lock");
-my @wait_how = (
- "simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c)
- "repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
- "twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
-);
+ if ($test_type =~ 'twain') {
+ no warnings 'threads'; # lock var != cond var, so disable warnings
+ cond_signal($cond);
+ } else {
+ cond_signal($cond);
+ }
+ ok($testno++, 1, "$test_type: child signalled condition");
-SYNC_SHARED: {
- my $test : shared; # simple|repeat|twain
- my $cond : shared;
- my $lock : shared;
-
- ok(1, 1, "Shared synchronization tests preparation");
- $Base += 1;
-
- sub signaller {
- ok(2,1,"$test: child before lock");
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(3,1,"$test: child obtained lock");
- if ($test =~ 'twain') {
- no warnings 'threads'; # lock var != cond var, so disable warnings
- cond_signal($cond);
- } else {
- cond_signal($cond);
+ return($testno);
}
- ok(4,1,"$test: child signalled condition");
- }
- # - TEST cond_timedwait success
+ sub ctw_ok
+ {
+ my ($testnum, $to) = @_;
+
+ # Which lock to obtain?
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+
+ my $thr = threads->create(\&signaller, $testnum);
+ my $ok = 0;
+ for ($test_type) {
+ $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_type: unknown test\n";
+ }
+ $testnum = $thr->join();
+ ok($testnum++, $ok, "$test_type: condition obtained");
- forko( sub {
- foreach (@wait_how) {
- $test = "cond_timedwait [$_]";
- threads->create(\&ctw, 0.05)->join;
- $Base += 5;
+ return ($testnum);
}
- }, 5*@wait_how, 5);
-
- sub ctw($) {
- my $to = shift;
-
- # which lock to obtain?
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
-
- 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";
- }
- $thr->join;
- ok(5,$ok, "$test: condition obtained");
- }
-
- # - TEST cond_timedwait timeout
-
- forko( sub {
+
foreach (@wait_how) {
- $test = "cond_timedwait pause, timeout [$_]";
- threads->create(\&ctw_fail, 0.3)->join;
- $Base += 2;
+ $test_type = "cond_timedwait [$_]";
+ my $thr = threads->create(\&ctw_ok, $TEST, 0.05);
+ $TEST = $thr->join();
+ }
+
+ # - TEST cond_timedwait timeout
+
+ sub ctw_fail
+ {
+ my ($testnum, $to) = @_;
+
+ if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
+ # The lock obtaining would pass, but the wait will not.
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+ ok($testnum++, 0, "# SKIP see perl583delta");
+
+ } else {
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+ my $ok;
+ for ($test_type) {
+ $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_type: unknown test\n";
+ }
+ ok($testnum++, ! defined($ok), "$test_type: timeout");
+ }
+
+ return ($testnum);
}
- }, 2*@wait_how, 5);
- forko( sub {
foreach (@wait_how) {
- $test = "cond_timedwait instant timeout [$_]";
- threads->create(\&ctw_fail, -0.60)->join;
- $Base += 2;
+ $test_type = "cond_timedwait pause, timeout [$_]";
+ my $thr = threads->create(\&ctw_fail, $TEST, 0.3);
+ $TEST = $thr->join();
}
- }, 2*@wait_how, 5);
-
- # 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 {
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
- my $ok;
- my $delta = time();
- 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";
- }
- $delta = time() - $delta;
- ok(2, ! defined($ok), "$test: timeout");
-
- if (($to > 0) && ($^O ne 'os2')) {
- # Timing tests can be problematic
- if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
- print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
- }
- }
+
+ foreach (@wait_how) {
+ $test_type = "cond_timedwait instant timeout [$_]";
+ my $thr = threads->create(\&ctw_fail, $TEST, -0.60);
+ $TEST = $thr->join();
}
- }
} # -- SYNCH_SHARED block
# same as above, but with references to lock and cond vars
SYNCH_REFS: {
- my $test : shared; # simple|repeat|twain
+ my $test_type :shared; # simple|repeat|twain
- my $true_cond; share($true_cond);
- my $true_lock; share($true_lock);
+ my $true_cond :shared;
+ my $true_lock :shared;
- my $cond = \$true_cond;
- my $lock = \$true_lock;
+ my $cond = \$true_cond;
+ my $lock = \$true_lock;
- ok(1, 1, "Synchronization reference tests preparation");
- $Base += 1;
+ ok($TEST++, 1, "Synchronization reference tests preparation");
- sub signaller2 {
- ok(2,1,"$test: child before lock");
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(3,1,"$test: child obtained lock");
- if ($test =~ 'twain') {
- no warnings 'threads'; # lock var != cond var, so disable warnings
- cond_signal($cond);
- } else {
- cond_signal($cond);
+ # - TEST cond_timedwait success
+
+ sub signaller2
+ {
+ my $testno = $_[0];
+
+ ok($testno++, 1, "$test_type: child before lock");
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testno++, 1, "$test_type: child obtained lock");
+
+ if ($test_type =~ 'twain') {
+ no warnings 'threads'; # lock var != cond var, so disable warnings
+ cond_signal($cond);
+ } else {
+ cond_signal($cond);
+ }
+ ok($testno++, 1, "$test_type: child signalled condition");
+
+ return($testno);
}
- ok(4,1,"$test: child signalled condition");
- }
- # - TEST cond_timedwait success
+ sub ctw_ok2
+ {
+ my ($testnum, $to) = @_;
+
+ # Which lock to obtain?
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+
+ my $thr = threads->create(\&signaller2, $testnum);
+ my $ok = 0;
+ for ($test_type) {
+ $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_type: unknown test\n";
+ }
+ $testnum = $thr->join();
+ ok($testnum++, $ok, "$test_type: condition obtained");
- forko( sub {
- foreach (@wait_how) {
- $test = "cond_timedwait [$_]";
- threads->create(\&ctw2, 0.05)->join;
- $Base += 5;
+ return ($testnum);
}
- }, 5*@wait_how, 5);
-
- sub ctw2($) {
- my $to = shift;
-
- # which lock to obtain?
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
-
- 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";
- }
- $thr->join;
- ok(5,$ok, "$test: condition obtained");
- }
-
- # - TEST cond_timedwait timeout
-
- forko( sub {
+
foreach (@wait_how) {
- $test = "cond_timedwait pause, timeout [$_]";
- threads->create(\&ctw_fail2, 0.3)->join;
- $Base += 2;
+ $test_type = "cond_timedwait [$_]";
+ my $thr = threads->create(\&ctw_ok2, $TEST, 0.05);
+ $TEST = $thr->join();
}
- }, 2*@wait_how, 5);
- forko( sub {
- foreach (@wait_how) {
- $test = "cond_timedwait instant timeout [$_]";
- threads->create(\&ctw_fail2, -0.60)->join;
- $Base += 2;
+ # - TEST cond_timedwait timeout
+
+ sub ctw_fail2
+ {
+ my ($testnum, $to) = @_;
+
+ if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
+ # The lock obtaining would pass, but the wait will not.
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+ ok($testnum++, 0, "# SKIP see perl583delta");
+
+ } else {
+ $test_type =~ /twain/ ? lock($lock) : lock($cond);
+ ok($testnum++, 1, "$test_type: obtained initial lock");
+ my $ok;
+ for ($test_type) {
+ $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_type: unknown test\n";
+ }
+ ok($testnum++, ! defined($ok), "$test_type: timeout");
+ }
+
+ return ($testnum);
}
- }, 2*@wait_how, 5);
- sub ctw_fail2 {
- my $to = shift;
+ foreach (@wait_how) {
+ $test_type = "cond_timedwait pause, timeout [$_]";
+ my $thr = threads->create(\&ctw_fail2, $TEST, 0.3);
+ $TEST = $thr->join();
+ }
- 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 {
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
- my $ok;
- my $delta = time();
- 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";
- }
- $delta = time() - $delta;
- ok(2, ! $ok, "$test: timeout");
-
- if (($to > 0) && ($^O ne 'os2')) {
- # Timing tests can be problematic
- if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
- print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
- }
- }
+ foreach (@wait_how) {
+ $test_type = "cond_timedwait instant timeout [$_]";
+ my $thr = threads->create(\&ctw_fail2, $TEST, -0.60);
+ $TEST = $thr->join();
}
- }
} # -- SYNCH_REFS block
+# Kill timer process
+if ($timer_pid && kill(0, $timer_pid)) {
+ kill('KILL', $timer_pid);
+}
+
+# Done
exit(0);
# EOF
projects / p5sagit/p5-mst-13.2.git / commitdiff