dist/threads-shared/t/stress.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     use Config;
   6     if (! $Config{'useithreads'}) {
   7         print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
   8         exit(0);
   9     }
  10     if ($^O eq 'hpux' && $Config{osvers} <= 10.20) {
  11         print("1..0 # SKIP Broken under HP-UX 10.20\n");
  12         exit(0);
  13     }
  14 }
  15
  16 use ExtUtils::testlib;
  17
  18 BEGIN {
  19     $| = 1;
  20     print("1..1\n");   ### Number of tests that will be run ###
  21 };
  22
  23 use threads;
  24 use threads::shared;
  25
  26 ### Start of Testing ###
  27
  28 #####
  29 #
  30 # Launches a bunch of threads which are then
  31 # restricted to finishing in numerical order
  32 #
  33 #####
  34 {
  35     my $cnt = 50;
  36
  37     my $TIMEOUT = 60;
  38
  39     my $mutex = 1;
  40     share($mutex);
  41
  42     my $warning;
  43     $SIG{__WARN__} = sub { $warning = shift; };
  44
  45     my @threads;
  46
  47     for (reverse(1..$cnt)) {
  48         $threads[$_] = threads->create(sub {
  49                             my $tnum = shift;
  50                             my $timeout = time() + $TIMEOUT;
  51                             threads->yield();
  52
  53                             # Randomize the amount of work the thread does
  54                             my $sum;
  55                             for (0..(500000+int(rand(500000)))) {
  56                                 $sum++
  57                             }
  58
  59                             # Lock the mutex
  60                             lock($mutex);
  61
  62                             # Wait for my turn to finish
  63                             while ($mutex != $tnum) {
  64                                 if (! cond_timedwait($mutex, $timeout)) {
  65                                     if ($mutex == $tnum) {
  66                                         return ('timed out - cond_broadcast not received');
  67                                     } else {
  68                                         return ('timed out');
  69                                     }
  70                                 }
  71                             }
  72
  73                             # Finish up
  74                             $mutex++;
  75                             cond_broadcast($mutex);
  76                             return ('okay');
  77                       }, $_);
  78
  79         # Handle thread creation failures
  80         if ($warning) {
  81             my $printit = 1;
  82             if ($warning =~ /returned 11/) {
  83                 $warning = "Thread creation failed due to 'No more processes'\n";
  84                 $printit = (! $ENV{'PERL_CORE'});
  85             } elsif ($warning =~ /returned 12/) {
  86                 $warning = "Thread creation failed due to 'No more memory'\n";
  87                 $printit = (! $ENV{'PERL_CORE'});
  88             }
  89             print(STDERR "# Warning: $warning") if ($printit);
  90             lock($mutex);
  91             $mutex = $_ + 1;
  92             last;
  93         }
  94     }
  95
  96     # Gather thread results
  97     my ($okay, $failures, $timeouts, $unknown) = (0, 0, 0, 0, 0);
  98     for (1..$cnt) {
  99         if (! $threads[$_]) {
 100             $failures++;
 101         } else {
 102             my $rc = $threads[$_]->join();
 103             if (! $rc) {
 104                 $failures++;
 105             } elsif ($rc =~ /^timed out/) {
 106                 $timeouts++;
 107             } elsif ($rc eq 'okay') {
 108                 $okay++;
 109             } else {
 110                 $unknown++;
 111                 print(STDERR "# Unknown error: $rc\n");
 112             }
 113         }
 114     }
 115
 116     if ($failures) {
 117         my $only = $cnt - $failures;
 118         print(STDERR "# Warning: Intended to use $cnt threads, but could only muster $only\n");
 119         $cnt -= $failures;
 120     }
 121
 122     if ($unknown || (($okay + $timeouts) != $cnt)) {
 123         print("not ok 1\n");
 124         my $too_few = $cnt - ($okay + $timeouts + $unknown);
 125         print(STDERR "# Test failed:\n");
 126         print(STDERR "#\t$too_few too few threads reported\n") if $too_few;
 127         print(STDERR "#\t$unknown unknown errors\n")           if $unknown;
 128         print(STDERR "#\t$timeouts threads timed out\n")       if $timeouts;
 129
 130     } elsif ($timeouts) {
 131         # Frequently fails under MSWin32 due to deadlocking bug in Windows
 132         # hence test is TODO under MSWin32
 133         #   http://rt.perl.org/rt3/Public/Bug/Display.html?id=41574
 134         #   http://support.microsoft.com/kb/175332
 135         if ($^O eq 'MSWin32') {
 136             print("not ok 1 # TODO - not reliable under MSWin32\n")
 137         } else {
 138             print("not ok 1\n");
 139             print(STDERR "# Test failed: $timeouts threads timed out\n");
 140         }
 141
 142     } else {
 143         print("ok 1\n");
 144     }
 145 }
 146
 147 exit(0);
 148
 149 # EOF