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       ok(2, ! defined($ok), "$test: timeout");
 209
 210       if (($to > 0) && ($^O ne 'os2')) {
 211         # Timing tests can be problematic
 212         if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
 213           print(STDERR "# Timeout: specified=$to  actual=$delta secs.\n");
 214         }
 215       }
 216     }
 217   }
 218
 219 } # -- SYNCH_SHARED block
 220
 221
 222 # same as above, but with references to lock and cond vars
 223
 224 SYNCH_REFS: {
 225   my $test : shared;  # simple|repeat|twain
 226
 227   my $true_cond; share($true_cond);
 228   my $true_lock; share($true_lock);
 229
 230   my $cond = \$true_cond;
 231   my $lock = \$true_lock;
 232
 233   ok(1, 1, "Synchronization reference tests preparation");
 234   $Base += 1;
 235
 236   sub signaller2 {
 237     ok(2,1,"$test: child before lock");
 238     $test =~ /twain/ ? lock($lock) : lock($cond);
 239     ok(3,1,"$test: child obtained lock");
 240     if ($test =~ 'twain') {
 241       no warnings 'threads';   # lock var != cond var, so disable warnings
 242       cond_signal($cond);
 243     } else {
 244       cond_signal($cond);
 245     }
 246     ok(4,1,"$test: child signalled condition");
 247   }
 248
 249   # - TEST cond_timedwait success
 250
 251   forko( sub {
 252     foreach (@wait_how) {
 253       $test = "cond_timedwait [$_]";
 254       threads->create(\&ctw2, 0.05)->join;
 255       $Base += 6;
 256     }
 257   }, 6*@wait_how, 5);
 258
 259   sub ctw2($) {
 260     my $to = shift;
 261     my $thr;
 262
 263     { # -- begin lock scope;  which lock to obtain?
 264       $test =~ /twain/ ? lock($lock) : lock($cond);
 265       ok(1,1, "$test: obtained initial lock");
 266
 267       $thr = threads->create(\&signaller2);
 268       my $ok = 0;
 269       for ($test) {
 270         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 271         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 272         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 273         die "$test: unknown test\n";
 274       }
 275       ok(5,$ok, "$test: condition obtained");
 276     } # -- end lock scope
 277
 278     $thr->join;
 279     ok(6,1, "$test: join completed");
 280   }
 281
 282   # - TEST cond_timedwait timeout
 283
 284   forko( sub {
 285     foreach (@wait_how) {
 286       $test = "cond_timedwait pause, timeout [$_]";
 287       threads->create(\&ctw_fail2, 0.3)->join;
 288       $Base += 2;
 289     }
 290   }, 2*@wait_how, 5);
 291
 292   forko( sub {
 293     foreach (@wait_how) {
 294       $test = "cond_timedwait instant timeout [$_]";
 295       threads->create(\&ctw_fail2, -0.60)->join;
 296       $Base += 2;
 297     }
 298   }, 2*@wait_how, 5);
 299
 300   sub ctw_fail2 {
 301     my $to = shift;
 302
 303     if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
 304       # The lock obtaining would pass, but the wait will not.
 305       ok(1,1, "$test: obtained initial lock");
 306       ok(2,0, "# SKIP see perl583delta");
 307     } else {
 308       $test =~ /twain/ ? lock($lock) : lock($cond);
 309       ok(1,1, "$test: obtained initial lock");
 310       my $ok;
 311       my $delta = time();
 312       for ($test) {
 313         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
 314         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
 315         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
 316         die "$test: unknown test\n";
 317       }
 318       $delta = time() - $delta;
 319       ok(2, ! $ok, "$test: timeout");
 320
 321       if (($to > 0) && ($^O ne 'os2')) {
 322         # Timing tests can be problematic
 323         if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
 324           print(STDERR "# Timeout: specified=$to  actual=$delta secs.\n");
 325         }
 326       }
 327     }
 328   }
 329
 330 } # -- SYNCH_REFS block
 331
 332 # EOF