Upgrade to threads-shared-1.03

[p5sagit/p5-mst-13.2.git] / ext / threads / shared / t / wait.t

diff --git a/ext/threads/shared/t/wait.t b/ext/threads/shared/t/wait.t
index d1b7c0a..b0c7d9e 100644 (file)
--- a/ext/threads/shared/t/wait.t
+++ b/ext/threads/shared/t/wait.t
@@ -1,34 +1,60 @@
-# 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..103\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.
@@ -93,7 +119,6 @@ SYNC_SHARED: {
   my $cond : shared;
   my $lock : shared;
 
-  print "# testing my \$var : shared\n";
   ok(1, 1, "Shared synchronization tests preparation");
   $Base += 1;
 
@@ -194,17 +219,22 @@ SYNC_SHARED: {
   # 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
@@ -221,7 +251,6 @@ SYNCH_REFS: {
   my $cond = \$true_cond;
   my $lock = \$true_lock;
 
-  print "# testing reference to shared(\$var)\n";
   ok(1, 1, "Synchronization reference tests preparation");
   $Base += 1;
 
@@ -322,17 +351,24 @@ SYNCH_REFS: {
   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
 
+# EOF