-# 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..90\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.
+
+*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;
+
+ my $bump = $expected;
+
+ 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;
+ }
+
+ close(CHLD);
+
+ while ($expected--) {
+ ok(++$test_num, 0, "missing test result: child status $?");
+ }
+
+ $Base += $bump;
+};
+
+
# - TEST basics
ok(1, defined &cond_wait, "cond_wait() present");
}
# - TEST cond_wait
- foreach (@wait_how) {
- $test = "cond_wait [$_]";
- threads->create(\&cw)->join;
- $Base += 5;
- }
+ forko( sub {
+ foreach (@wait_how) {
+ $test = "cond_wait [$_]";
+ threads->create(\&cw)->join;
+ $Base += 5;
+ }
+ }, 5*@wait_how, 90);
sub cw {
- ## which lock to obtain in this scope?
- $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");
+ # 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
- foreach (@wait_how) {
- $test = "cond_timedwait [$_]";
- threads->create(\&ctw, 5)->join;
- $Base += 5;
- }
+ forko( sub {
+ foreach (@wait_how) {
+ $test = "cond_timedwait [$_]";
+ threads->create(\&ctw, 5)->join;
+ $Base += 5;
+ }
+ }, 5*@wait_how, 90);
sub ctw($) {
- my $to = shift;
-
- ## which lock to obtain in this scope?
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
-
- my $thr = threads->create(\&signaller);
- ### N.B.: RACE! If $timeout is very soon and/or we are unlucky, we
- ### might timeout on the cond_timedwait before the signaller
- ### thread even attempts lock()ing.
- ### Upshot: $thr->join() never completes, because signaller is
- ### stuck attempting to lock the mutex we regained after waiting.
- 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";
- }
- print "# back from cond_timedwait; join()ing\n";
- $thr->join;
- ok(5,$ok, "$test: condition obtained");
+ 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
- foreach (@wait_how) {
- $test = "cond_timedwait pause, timeout [$_]";
- threads->create(\&ctw_fail, 3)->join;
- $Base += 2;
- }
+ forko( sub {
+ foreach (@wait_how) {
+ $test = "cond_timedwait pause, timeout [$_]";
+ threads->create(\&ctw_fail, 3)->join;
+ $Base += 2;
+ }
+ }, 2*@wait_how, 90);
- foreach (@wait_how) {
- $test = "cond_timedwait instant timeout [$_]";
- threads->create(\&ctw_fail, -60)->join;
- $Base += 2;
- }
+ forko( sub {
+ foreach (@wait_how) {
+ $test = "cond_timedwait instant timeout [$_]";
+ threads->create(\&ctw_fail, -60)->join;
+ $Base += 2;
+ }
+ }, 2*@wait_how, 90);
# cond_timedwait timeout (relative timeout)
sub ctw_fail {
my $to = shift;
-
- $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";
+ 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");
}
- ok(2,!defined($ok), "$test: timeout");
}
} # -- SYNCH_SHARED block
SYNCH_REFS: {
my $test : shared; # simple|repeat|twain
-
+
my $true_cond; share($true_cond);
my $true_lock; share($true_lock);
}
# - TEST cond_wait
- foreach (@wait_how) {
- $test = "cond_wait [$_]";
- threads->create(\&cw2)->join;
- $Base += 5;
- }
+ forko( sub {
+ foreach (@wait_how) {
+ $test = "cond_wait [$_]";
+ threads->create(\&cw2)->join;
+ $Base += 5;
+ }
+ }, 5*@wait_how, 90);
sub cw2 {
- ## which lock to obtain in this scope?
- $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");
+ # 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
- foreach (@wait_how) {
- $test = "cond_timedwait [$_]";
- threads->create(\&ctw2, 5)->join;
- $Base += 5;
- }
+ forko( sub {
+ foreach (@wait_how) {
+ $test = "cond_timedwait [$_]";
+ threads->create(\&ctw2, 5)->join;
+ $Base += 5;
+ }
+ }, 5*@wait_how, 90);
sub ctw2($) {
- my $to = shift;
-
- ## which lock to obtain in this scope?
- $test =~ /twain/ ? lock($lock) : lock($cond);
- ok(1,1, "$test: obtained initial lock");
-
- my $thr = threads->create(\&signaller2);
- ### N.B.: RACE! as above, with ctw()
- 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");
+ 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
- foreach (@wait_how) {
- $test = "cond_timedwait pause, timeout [$_]";
- threads->create(\&ctw_fail2, 3)->join;
- $Base += 2;
- }
+ forko( sub {
+ foreach (@wait_how) {
+ $test = "cond_timedwait pause, timeout [$_]";
+ threads->create(\&ctw_fail2, 3)->join;
+ $Base += 2;
+ }
+ }, 2*@wait_how, 90);
- foreach (@wait_how) {
- $test = "cond_timedwait instant timeout [$_]";
- threads->create(\&ctw_fail2, -60)->join;
- $Base += 2;
- }
+ forko( sub {
+ foreach (@wait_how) {
+ $test = "cond_timedwait instant timeout [$_]";
+ threads->create(\&ctw_fail2, -60)->join;
+ $Base += 2;
+ }
+ }, 2*@wait_how, 90);
sub ctw_fail2 {
my $to = shift;
- $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";
+ 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");
}
- ok(2,!$ok, "$test: timeout");
}
} # -- SYNCH_REFS block
+exit(0);
+
+# EOF
projects / p5sagit/p5-mst-13.2.git / blobdiff