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