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