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