ext/threads/shared/t/wait.t

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