ext/threads/shared/t/waithires.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     if ($ENV{'PERL_CORE'}){
   6         chdir 't';
   7         unshift @INC, '../lib';
   8     }
   9     use Config;
  10     if (! $Config{'useithreads'}) {
  11         print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
  12         exit(0);
  13     }
  14     eval {
  15         require Time::HiRes;
  16         import Time::HiRes qw(time);
  17     };
  18     if ($@) {
  19         print("1..0 # Skip: Time::HiRes not available.\n");
  20         exit(0);
  21     }
  22 }
  23
  24 use ExtUtils::testlib;
  25
  26 my $Base = 0;
  27 sub ok {
  28     my ($id, $ok, $name) = @_;
  29     $id += $Base;
  30
  31     # You have to do it this way or VMS will get confused.
  32     if ($ok) {
  33         print("ok $id - $name\n");
  34     } else {
  35         print("not ok $id - $name\n");
  36         printf("# Failed test at line %d\n", (caller)[2]);
  37     }
  38
  39     return ($ok);
  40 }
  41
  42 BEGIN {
  43     $| = 1;
  44     print("1..63\n");   ### Number of tests that will be run ###
  45 };
  46
  47 use threads;
  48 use threads::shared;
  49
  50 ok(1, 1, 'Loaded');
  51 $Base++;
  52
  53 ### Start of Testing ###
  54
  55 # subsecond cond_timedwait extended tests adapted from wait.t
  56
  57 # The two skips later on in these tests refer to this quote from the
  58 # pod/perl583delta.pod:
  59 #
  60 # =head1 Platform Specific Problems
  61 #
  62 # The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
  63 # and HP-UX 10.20 due to bugs in their threading implementations.
  64 # RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
  65 # and consider upgrading their glibc.
  66
  67 sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
  68                  # stock RH9 glibc/NPTL) or from our own errors, we run tests
  69                  # in separately forked and alarmed processes.
  70
  71 *forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
  72 ? sub (&$$) { my $code = shift; goto &$code; }
  73 : sub (&$$) {
  74   my ($code, $expected, $patience) = @_;
  75   my ($test_num, $pid);
  76   local *CHLD;
  77
  78   my $bump = $expected;
  79
  80   $patience ||= 60;
  81
  82   unless (defined($pid = open(CHLD, "-|"))) {
  83     die "fork: $!\n";
  84   }
  85   if (! $pid) {   # Child -- run the test
  86     $patience ||= 60;
  87     alarm $patience;
  88     &$code;
  89     exit;
  90   }
  91
  92   while (<CHLD>) {
  93     $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
  94     #print "#forko: ($expected, $1) $_";
  95     print;
  96   }
  97
  98   close(CHLD);
  99
 100   while ($expected--) {
 101     $test_num++;
 102     print "not ok $test_num - child status $?\n";
 103   }
 104
 105   $Base += $bump;
 106
 107 };
 108
 109 # - TEST basics
 110
 111 my @wait_how = (
 112    "simple",  # cond var == lock var; implicit lock; e.g.: cond_wait($c)
 113    "repeat",  # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
 114    "twain"    # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
 115 );
 116
 117 SYNC_SHARED: {
 118   my $test : shared;  # simple|repeat|twain
 119   my $cond : shared;
 120   my $lock : shared;
 121
 122   ok(1, 1, "Shared synchronization tests preparation");
 123   $Base += 1;
 124
 125   sub signaller {
 126     ok(2,1,"$test: child before lock");
 127     $test =~ /twain/ ? lock($lock) : lock($cond);
 128     ok(3,1,"$test: child obtained lock");
 129     if ($test =~ 'twain') {
 130       no warnings 'threads';   # lock var != cond var, so disable warnings
 131       cond_signal($cond);
 132     } else {
 133       cond_signal($cond);
 134     }
 135     ok(4,1,"$test: child signalled condition");
 136   }
 137
 138   # - TEST cond_timedwait success
 139
 140   forko( sub {
 141     foreach (@wait_how) {
 142       $test = "cond_timedwait [$_]";
 143       threads->create(\&ctw, 0.05)->join;
 144       $Base += 6;
 145     }
 146   }, 6*@wait_how, 5);
 147
 148   sub ctw($) {
 149     my $to = shift;
 150     my $thr;
 151
 152     { # -- begin lock scope;  which lock to obtain?
 153       $test =~ /twain/ ? lock($lock) : lock($cond);
 154       ok(1,1, "$test: obtained initial lock");
 155
 156       $thr = threads->create(\&signaller);
 157       my $ok = 0;
 158       for ($test) {
 159         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 160         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 161         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 162         die "$test: unknown test\n";
 163       }
 164       ok(5,$ok, "$test: condition obtained");
 165     } # -- end lock scope
 166
 167     $thr->join;
 168     ok(6,1, "$test: join completed");
 169   }
 170
 171   # - TEST cond_timedwait timeout
 172
 173   forko( sub {
 174     foreach (@wait_how) {
 175       $test = "cond_timedwait pause, timeout [$_]";
 176       threads->create(\&ctw_fail, 0.3)->join;
 177       $Base += 2;
 178     }
 179   }, 2*@wait_how, 5);
 180
 181   forko( sub {
 182     foreach (@wait_how) {
 183       $test = "cond_timedwait instant timeout [$_]";
 184       threads->create(\&ctw_fail, -0.60)->join;
 185       $Base += 2;
 186     }
 187   }, 2*@wait_how, 5);
 188
 189   # cond_timedwait timeout (relative timeout)
 190   sub ctw_fail {
 191     my $to = shift;
 192     if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
 193       # The lock obtaining would pass, but the wait will not.
 194       ok(1,1, "$test: obtained initial lock");
 195       ok(2,0, "# SKIP see perl583delta");
 196     } else {
 197       $test =~ /twain/ ? lock($lock) : lock($cond);
 198       ok(1,1, "$test: obtained initial lock");
 199       my $ok;
 200       my $delta = time();
 201       for ($test) {
 202         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 203         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 204         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 205         die "$test: unknown test\n";
 206       }
 207       $delta = time() - $delta;
 208       if (($to < 0) || ($^O eq 'os2')) {
 209         ok(2, ! defined($ok), "$test: timeout");
 210       } else {
 211         # This is a bit problematic, as scheduling and compute latencies
 212         # can inject delays in our computation. For now, assume -10/+20%
 213         # is reasonable
 214         if (! ok(2, ! defined($ok) &&
 215                     ($delta > (0.9 * $to)) &&
 216                     ($delta < (1.2 * $to)),
 217                         "$test: timeout"))
 218         {
 219             print(STDERR "# Timeout: specified=$to  actual=$delta secs.\n");
 220         }
 221       }
 222     }
 223   }
 224
 225 } # -- SYNCH_SHARED block
 226
 227
 228 # same as above, but with references to lock and cond vars
 229
 230 SYNCH_REFS: {
 231   my $test : shared;  # simple|repeat|twain
 232
 233   my $true_cond; share($true_cond);
 234   my $true_lock; share($true_lock);
 235
 236   my $cond = \$true_cond;
 237   my $lock = \$true_lock;
 238
 239   ok(1, 1, "Synchronization reference tests preparation");
 240   $Base += 1;
 241
 242   sub signaller2 {
 243     ok(2,1,"$test: child before lock");
 244     $test =~ /twain/ ? lock($lock) : lock($cond);
 245     ok(3,1,"$test: child obtained lock");
 246     if ($test =~ 'twain') {
 247       no warnings 'threads';   # lock var != cond var, so disable warnings
 248       cond_signal($cond);
 249     } else {
 250       cond_signal($cond);
 251     }
 252     ok(4,1,"$test: child signalled condition");
 253   }
 254
 255   # - TEST cond_timedwait success
 256
 257   forko( sub {
 258     foreach (@wait_how) {
 259       $test = "cond_timedwait [$_]";
 260       threads->create(\&ctw2, 0.05)->join;
 261       $Base += 6;
 262     }
 263   }, 6*@wait_how, 5);
 264
 265   sub ctw2($) {
 266     my $to = shift;
 267     my $thr;
 268
 269     { # -- begin lock scope;  which lock to obtain?
 270       $test =~ /twain/ ? lock($lock) : lock($cond);
 271       ok(1,1, "$test: obtained initial lock");
 272
 273       $thr = threads->create(\&signaller2);
 274       my $ok = 0;
 275       for ($test) {
 276         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 277         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 278         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 279         die "$test: unknown test\n";
 280       }
 281       ok(5,$ok, "$test: condition obtained");
 282     } # -- end lock scope
 283
 284     $thr->join;
 285     ok(6,1, "$test: join completed");
 286   }
 287
 288   # - TEST cond_timedwait timeout
 289
 290   forko( sub {
 291     foreach (@wait_how) {
 292       $test = "cond_timedwait pause, timeout [$_]";
 293       threads->create(\&ctw_fail2, 0.3)->join;
 294       $Base += 2;
 295     }
 296   }, 2*@wait_how, 5);
 297
 298   forko( sub {
 299     foreach (@wait_how) {
 300       $test = "cond_timedwait instant timeout [$_]";
 301       threads->create(\&ctw_fail2, -0.60)->join;
 302       $Base += 2;
 303     }
 304   }, 2*@wait_how, 5);
 305
 306   sub ctw_fail2 {
 307     my $to = shift;
 308
 309     if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
 310       # The lock obtaining would pass, but the wait will not.
 311       ok(1,1, "$test: obtained initial lock");
 312       ok(2,0, "# SKIP see perl583delta");
 313     } else {
 314       $test =~ /twain/ ? lock($lock) : lock($cond);
 315       ok(1,1, "$test: obtained initial lock");
 316       my $ok;
 317       my $delta = time();
 318       for ($test) {
 319         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 320         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 321         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 322         die "$test: unknown test\n";
 323       }
 324       $delta = time() - $delta;
 325       if (($to < 0) || ($^O eq 'os2')) {
 326         ok(2,!$ok, "$test: timeout");
 327       } else {
 328         # This is a bit problematic, as scheduling and compute latencies
 329         # can inject delays in our computation. For now, assume -10/+20%
 330         # is reasonable
 331         if (! ok(2, ! $ok &&
 332                     ($delta > (0.9 * $to)) &&
 333                     ($delta < (1.2 * $to)),
 334                         "$test: timeout"))
 335         {
 336             print(STDERR "# Timeout: specified=$to  actual=$delta secs.\n");
 337         }
 338       }
 339     }
 340   }
 341
 342 } # -- SYNCH_REFS block
 343
 344 # EOF