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..103\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 sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
  59                  # stock RH9 glibc/NPTL) or from our own errors, we run tests
  60                  # in separately forked and alarmed processes.
  61
  62 *forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
  63 ? sub (&$$) { my $code = shift; goto &$code; }
  64 : sub (&$$) {
  65   my ($code, $expected, $patience) = @_;
  66   my ($test_num, $pid);
  67   local *CHLD;
  68
  69   my $bump = $expected;
  70
  71   $patience ||= 60;
  72
  73   unless (defined($pid = open(CHLD, "-|"))) {
  74     die "fork: $!\n";
  75   }
  76   if (! $pid) {   # Child -- run the test
  77     $patience ||= 60;
  78     alarm $patience;
  79     &$code;
  80     exit;
  81   }
  82
  83   while (<CHLD>) {
  84     $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
  85     #print "#forko: ($expected, $1) $_";
  86     print;
  87   }
  88
  89   close(CHLD);
  90
  91   while ($expected--) {
  92     $test_num++;
  93     print "not ok $test_num - child status $?\n";
  94   }
  95
  96   $Base += $bump;
  97
  98 };
  99
 100 # - TEST basics
 101
 102 ok(1, defined &cond_wait, "cond_wait() present");
 103 ok(2, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'),
 104     q|cond_wait() prototype '\[$@%];\[$@%]'|);
 105 ok(3, defined &cond_timedwait, "cond_timedwait() present");
 106 ok(4, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'),
 107     q|cond_timedwait() prototype '\[$@%]$;\[$@%]'|);
 108
 109 $Base += 4;
 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_wait
 139   forko( sub {
 140     foreach (@wait_how) {
 141       $test = "cond_wait [$_]";
 142       threads->create(\&cw)->join;
 143       $Base += 6;
 144     }
 145   }, 6*@wait_how, 90);
 146
 147   sub cw {
 148     my $thr;
 149
 150     { # -- begin lock scope; which lock to obtain?
 151       $test =~ /twain/ ? lock($lock) : lock($cond);
 152       ok(1,1, "$test: obtained initial lock");
 153
 154       $thr = threads->create(\&signaller);
 155       for ($test) {
 156         cond_wait($cond), last        if    /simple/;
 157         cond_wait($cond, $cond), last if    /repeat/;
 158         cond_wait($cond, $lock), last if    /twain/;
 159         die "$test: unknown test\n";
 160       }
 161       ok(5,1, "$test: condition obtained");
 162     } # -- end lock scope
 163
 164     $thr->join;
 165     ok(6,1, "$test: join completed");
 166   }
 167
 168   # - TEST cond_timedwait success
 169
 170   forko( sub {
 171     foreach (@wait_how) {
 172       $test = "cond_timedwait [$_]";
 173       threads->create(\&ctw, 5)->join;
 174       $Base += 6;
 175     }
 176   }, 6*@wait_how, 90);
 177
 178   sub ctw($) {
 179     my $to = shift;
 180     my $thr;
 181
 182     { # -- begin lock scope;  which lock to obtain?
 183       $test =~ /twain/ ? lock($lock) : lock($cond);
 184       ok(1,1, "$test: obtained initial lock");
 185
 186       $thr = threads->create(\&signaller);
 187       my $ok = 0;
 188       for ($test) {
 189         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 190         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 191         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 192         die "$test: unknown test\n";
 193       }
 194       ok(5,$ok, "$test: condition obtained");
 195     } # -- end lock scope
 196
 197     $thr->join;
 198     ok(6,1, "$test: join completed");
 199   }
 200
 201   # - TEST cond_timedwait timeout
 202
 203   forko( sub {
 204     foreach (@wait_how) {
 205       $test = "cond_timedwait pause, timeout [$_]";
 206       threads->create(\&ctw_fail, 3)->join;
 207       $Base += 2;
 208     }
 209   }, 2*@wait_how, 90);
 210
 211   forko( sub {
 212     foreach (@wait_how) {
 213       $test = "cond_timedwait instant timeout [$_]";
 214       threads->create(\&ctw_fail, -60)->join;
 215       $Base += 2;
 216     }
 217   }, 2*@wait_how, 90);
 218
 219   # cond_timedwait timeout (relative timeout)
 220   sub ctw_fail {
 221     my $to = shift;
 222     if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
 223       # The lock obtaining would pass, but the wait will not.
 224       ok(1,1, "$test: obtained initial lock");
 225       ok(2,0, "# SKIP see perl583delta");
 226     } else {
 227       $test =~ /twain/ ? lock($lock) : lock($cond);
 228       ok(1,1, "$test: obtained initial lock");
 229       my $ok;
 230       for ($test) {
 231         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 232         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 233         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 234         die "$test: unknown test\n";
 235       }
 236       ok(2,!defined($ok), "$test: timeout");
 237     }
 238   }
 239
 240 } # -- SYNCH_SHARED block
 241
 242
 243 # same as above, but with references to lock and cond vars
 244
 245 SYNCH_REFS: {
 246   my $test : shared;  # simple|repeat|twain
 247
 248   my $true_cond; share($true_cond);
 249   my $true_lock; share($true_lock);
 250
 251   my $cond = \$true_cond;
 252   my $lock = \$true_lock;
 253
 254   ok(1, 1, "Synchronization reference tests preparation");
 255   $Base += 1;
 256
 257   sub signaller2 {
 258     ok(2,1,"$test: child before lock");
 259     $test =~ /twain/ ? lock($lock) : lock($cond);
 260     ok(3,1,"$test: child obtained lock");
 261     if ($test =~ 'twain') {
 262       no warnings 'threads';   # lock var != cond var, so disable warnings
 263       cond_signal($cond);
 264     } else {
 265       cond_signal($cond);
 266     }
 267     ok(4,1,"$test: child signalled condition");
 268   }
 269
 270   # - TEST cond_wait
 271   forko( sub {
 272     foreach (@wait_how) {
 273       $test = "cond_wait [$_]";
 274       threads->create(\&cw2)->join;
 275       $Base += 6;
 276     }
 277   }, 6*@wait_how, 90);
 278
 279   sub cw2 {
 280     my $thr;
 281
 282     { # -- begin lock scope; which lock to obtain?
 283       $test =~ /twain/ ? lock($lock) : lock($cond);
 284       ok(1,1, "$test: obtained initial lock");
 285
 286       $thr = threads->create(\&signaller2);
 287       for ($test) {
 288         cond_wait($cond), last        if    /simple/;
 289         cond_wait($cond, $cond), last if    /repeat/;
 290         cond_wait($cond, $lock), last if    /twain/;
 291         die "$test: unknown test\n";
 292       }
 293       ok(5,1, "$test: condition obtained");
 294     } # -- end lock scope
 295
 296     $thr->join;
 297     ok(6,1, "$test: join completed");
 298   }
 299
 300   # - TEST cond_timedwait success
 301
 302   forko( sub {
 303     foreach (@wait_how) {
 304       $test = "cond_timedwait [$_]";
 305       threads->create(\&ctw2, 5)->join;
 306       $Base += 6;
 307     }
 308   }, 6*@wait_how, 90);
 309
 310   sub ctw2($) {
 311     my $to = shift;
 312     my $thr;
 313
 314     { # -- begin lock scope;  which lock to obtain?
 315       $test =~ /twain/ ? lock($lock) : lock($cond);
 316       ok(1,1, "$test: obtained initial lock");
 317
 318       $thr = threads->create(\&signaller2);
 319       my $ok = 0;
 320       for ($test) {
 321         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 322         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 323         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 324         die "$test: unknown test\n";
 325       }
 326       ok(5,$ok, "$test: condition obtained");
 327     } # -- end lock scope
 328
 329     $thr->join;
 330     ok(6,1, "$test: join completed");
 331   }
 332
 333   # - TEST cond_timedwait timeout
 334
 335   forko( sub {
 336     foreach (@wait_how) {
 337       $test = "cond_timedwait pause, timeout [$_]";
 338       threads->create(\&ctw_fail2, 3)->join;
 339       $Base += 2;
 340     }
 341   }, 2*@wait_how, 90);
 342
 343   forko( sub {
 344     foreach (@wait_how) {
 345       $test = "cond_timedwait instant timeout [$_]";
 346       threads->create(\&ctw_fail2, -60)->join;
 347       $Base += 2;
 348     }
 349   }, 2*@wait_how, 90);
 350
 351   sub ctw_fail2 {
 352     my $to = shift;
 353
 354     if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
 355       # The lock obtaining would pass, but the wait will not.
 356       ok(1,1, "$test: obtained initial lock");
 357       ok(2,0, "# SKIP see perl583delta");
 358     } else {
 359       $test =~ /twain/ ? lock($lock) : lock($cond);
 360       ok(1,1, "$test: obtained initial lock");
 361       my $ok;
 362       for ($test) {
 363         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 364         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 365         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 366         die "$test: unknown test\n";
 367       }
 368       ok(2,!$ok, "$test: timeout");
 369     }
 370   }
 371
 372 } # -- SYNCH_REFS block
 373
 374 # EOF