From: Jerry D. Hedden Date: Tue, 17 Jun 2008 16:28:45 +0000 (-0400) Subject: threads::shared 1.23 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=15b48317acf1797cdbfddc786e181f0842043250;p=p5sagit%2Fp5-mst-13.2.git threads::shared 1.23 From: "Jerry D. Hedden" Message-ID: <1ff86f510806171328y54650760u12c8148830a60a63@mail.gmail.com> p4raw-id: //depot/perl@34074 --- diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm index 37c0704..c73303b 100644 --- a/ext/threads/shared/shared.pm +++ b/ext/threads/shared/shared.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.22'; +our $VERSION = '1.23'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -186,7 +186,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.22 +This document describes threads::shared version 1.23 =head1 SYNOPSIS @@ -540,7 +540,7 @@ L Discussion Forum on CPAN: L Annotated POD for L: -L +L Source repository: L diff --git a/ext/threads/shared/t/wait.t b/ext/threads/shared/t/wait.t index 6863292..c08e2ed 100644 --- a/ext/threads/shared/t/wait.t +++ b/ext/threads/shared/t/wait.t @@ -1,12 +1,12 @@ 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); @@ -15,10 +15,30 @@ BEGIN { 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) { @@ -38,8 +58,10 @@ BEGIN { use threads; use threads::shared; -ok(1, 1, 'Loaded'); -$Base++; + +my $TEST = 1; +ok($TEST++, 1, 'Loaded'); + ### Start of Testing ### @@ -56,174 +78,147 @@ $Base++; # 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 () { - $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 @@ -231,125 +226,141 @@ SYNC_SHARED: { # 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 diff --git a/ext/threads/shared/t/waithires.t b/ext/threads/shared/t/waithires.t index b2e9146..2817334 100644 --- a/ext/threads/shared/t/waithires.t +++ b/ext/threads/shared/t/waithires.t @@ -1,12 +1,12 @@ 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); @@ -23,10 +23,30 @@ BEGIN { 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) { @@ -47,8 +67,9 @@ BEGIN { use threads; use threads::shared; -ok(1, 1, 'Loaded'); -$Base++; +my $TEST = 1; +ok($TEST++, 1, 'Loaded'); + ### Start of Testing ### @@ -65,149 +86,110 @@ $Base++; # 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 () { - $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 @@ -215,109 +197,112 @@ SYNC_SHARED: { # 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