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
  10     # Import test.pl into its own package
  11     {
  12         package Test;
  13         require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
  14     }
  15
  16     use Config;
  17     if (! $Config{'useithreads'}) {
  18         Test::skip_all(q/Perl not compiled with 'useithreads'/);
  19     }
  20
  21     if (! eval 'use Time::HiRes "time"; 1') {
  22         Test::skip_all('Time::HiRes not available');
  23     }
  24 }
  25
  26 use ExtUtils::testlib;
  27
  28 sub ok {
  29     my ($id, $ok, $name) = @_;
  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 Test::watchdog(60);   # In case we get stuck
  51
  52 my $TEST = 1;
  53 ok($TEST++, 1, 'Loaded');
  54
  55 ### Start of Testing ###
  56
  57 # subsecond cond_timedwait extended tests adapted from wait.t
  58
  59 # The two skips later on in these tests refer to this quote from the
  60 # pod/perl583delta.pod:
  61 #
  62 # =head1 Platform Specific Problems
  63 #
  64 # The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
  65 # and HP-UX 10.20 due to bugs in their threading implementations.
  66 # RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
  67 # and consider upgrading their glibc.
  68
  69
  70 # - TEST basics
  71
  72 my @wait_how = (
  73     "simple",  # cond var == lock var; implicit lock; e.g.: cond_wait($c)
  74     "repeat",  # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
  75     "twain"    # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
  76 );
  77
  78
  79 SYNC_SHARED: {
  80     my $test_type :shared;   # simple|repeat|twain
  81
  82     my $cond :shared;
  83     my $lock :shared;
  84
  85     ok($TEST++, 1, "Shared synchronization tests preparation");
  86
  87     # - TEST cond_timedwait success
  88
  89     sub signaller
  90     {
  91         my $testno = $_[0];
  92
  93         ok($testno++, 1, "$test_type: child before lock");
  94         $test_type =~ /twain/ ? lock($lock) : lock($cond);
  95         ok($testno++, 1, "$test_type: child obtained lock");
  96
  97         if ($test_type =~ 'twain') {
  98             no warnings 'threads';   # lock var != cond var, so disable warnings
  99             cond_signal($cond);
 100         } else {
 101             cond_signal($cond);
 102         }
 103         ok($testno++, 1, "$test_type: child signalled condition");
 104
 105         return($testno);
 106     }
 107
 108     sub ctw_ok
 109     {
 110         my ($testnum, $to) = @_;
 111
 112         # Which lock to obtain?
 113         $test_type =~ /twain/ ? lock($lock) : lock($cond);
 114         ok($testnum++, 1, "$test_type: obtained initial lock");
 115
 116         my $thr = threads->create(\&signaller, $testnum);
 117         my $ok = 0;
 118         for ($test_type) {
 119             $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
 120             $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
 121             $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
 122             die "$test_type: unknown test\n";
 123         }
 124         $testnum = $thr->join();
 125         ok($testnum++, $ok, "$test_type: condition obtained");
 126
 127         return ($testnum);
 128     }
 129
 130     foreach (@wait_how) {
 131         $test_type = "cond_timedwait [$_]";
 132         my $thr = threads->create(\&ctw_ok, $TEST, 0.1);
 133         $TEST = $thr->join();
 134     }
 135
 136     # - TEST cond_timedwait timeout
 137
 138     sub ctw_fail
 139     {
 140         my ($testnum, $to) = @_;
 141
 142         if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
 143             # The lock obtaining would pass, but the wait will not.
 144             ok($testnum++, 1, "$test_type: obtained initial lock");
 145             ok($testnum++, 0, "# SKIP see perl583delta");
 146
 147         } else {
 148             $test_type =~ /twain/ ? lock($lock) : lock($cond);
 149             ok($testnum++, 1, "$test_type: obtained initial lock");
 150             my $ok;
 151             for ($test_type) {
 152                 $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
 153                 $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
 154                 $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
 155                 die "$test_type: unknown test\n";
 156             }
 157             ok($testnum++, ! defined($ok), "$test_type: timeout");
 158         }
 159
 160         return ($testnum);
 161     }
 162
 163     foreach (@wait_how) {
 164         $test_type = "cond_timedwait pause, timeout [$_]";
 165         my $thr = threads->create(\&ctw_fail, $TEST, 0.3);
 166         $TEST = $thr->join();
 167     }
 168
 169     foreach (@wait_how) {
 170         $test_type = "cond_timedwait instant timeout [$_]";
 171         my $thr = threads->create(\&ctw_fail, $TEST, -0.60);
 172         $TEST = $thr->join();
 173     }
 174
 175 } # -- SYNCH_SHARED block
 176
 177
 178 # same as above, but with references to lock and cond vars
 179
 180 SYNCH_REFS: {
 181     my $test_type :shared;   # simple|repeat|twain
 182
 183     my $true_cond :shared;
 184     my $true_lock :shared;
 185
 186     my $cond = \$true_cond;
 187     my $lock = \$true_lock;
 188
 189     ok($TEST++, 1, "Synchronization reference tests preparation");
 190
 191     # - TEST cond_timedwait success
 192
 193     sub signaller2
 194     {
 195         my $testno = $_[0];
 196
 197         ok($testno++, 1, "$test_type: child before lock");
 198         $test_type =~ /twain/ ? lock($lock) : lock($cond);
 199         ok($testno++, 1, "$test_type: child obtained lock");
 200
 201         if ($test_type =~ 'twain') {
 202             no warnings 'threads';   # lock var != cond var, so disable warnings
 203             cond_signal($cond);
 204         } else {
 205             cond_signal($cond);
 206         }
 207         ok($testno++, 1, "$test_type: child signalled condition");
 208
 209         return($testno);
 210     }
 211
 212     sub ctw_ok2
 213     {
 214         my ($testnum, $to) = @_;
 215
 216         # Which lock to obtain?
 217         $test_type =~ /twain/ ? lock($lock) : lock($cond);
 218         ok($testnum++, 1, "$test_type: obtained initial lock");
 219
 220         my $thr = threads->create(\&signaller2, $testnum);
 221         my $ok = 0;
 222         for ($test_type) {
 223             $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
 224             $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
 225             $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
 226             die "$test_type: unknown test\n";
 227         }
 228         $testnum = $thr->join();
 229         ok($testnum++, $ok, "$test_type: condition obtained");
 230
 231         return ($testnum);
 232     }
 233
 234     foreach (@wait_how) {
 235         $test_type = "cond_timedwait [$_]";
 236         my $thr = threads->create(\&ctw_ok2, $TEST, 0.05);
 237         $TEST = $thr->join();
 238     }
 239
 240     # - TEST cond_timedwait timeout
 241
 242     sub ctw_fail2
 243     {
 244         my ($testnum, $to) = @_;
 245
 246         if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
 247             # The lock obtaining would pass, but the wait will not.
 248             ok($testnum++, 1, "$test_type: obtained initial lock");
 249             ok($testnum++, 0, "# SKIP see perl583delta");
 250
 251         } else {
 252             $test_type =~ /twain/ ? lock($lock) : lock($cond);
 253             ok($testnum++, 1, "$test_type: obtained initial lock");
 254             my $ok;
 255             for ($test_type) {
 256                 $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
 257                 $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
 258                 $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
 259                 die "$test_type: unknown test\n";
 260             }
 261             ok($testnum++, ! defined($ok), "$test_type: timeout");
 262         }
 263
 264         return ($testnum);
 265     }
 266
 267     foreach (@wait_how) {
 268         $test_type = "cond_timedwait pause, timeout [$_]";
 269         my $thr = threads->create(\&ctw_fail2, $TEST, 0.3);
 270         $TEST = $thr->join();
 271     }
 272
 273     foreach (@wait_how) {
 274         $test_type = "cond_timedwait instant timeout [$_]";
 275         my $thr = threads->create(\&ctw_fail2, $TEST, -0.60);
 276         $TEST = $thr->join();
 277     }
 278
 279 } # -- SYNCH_REFS block
 280
 281 # Done
 282 exit(0);
 283
 284 # EOF