ext/threads/shared/t/stress.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 }
  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 = 30;
  38
  39     my $mutex = 1;
  40     share($mutex);
  41
  42     my @threads;
  43     for (1..$cnt) {
  44         $threads[$_] = threads->create(sub {
  45                             my $tnum = shift;
  46                             my $timeout = time() + $TIMEOUT;
  47
  48                             # Randomize the amount of work the thread does
  49                             my $sum;
  50                             for (0..(500000+int(rand(500000)))) {
  51                                 $sum++
  52                             }
  53
  54                             # Lock the mutex
  55                             lock($mutex);
  56
  57                             # Wait for my turn to finish
  58                             while ($mutex != $tnum) {
  59                                 if (! cond_timedwait($mutex, $timeout)) {
  60                                     if ($mutex == $tnum) {
  61                                         return ('timed out - cond_broadcast not received');
  62                                     } else {
  63                                         return ('timed out');
  64                                     }
  65                                 }
  66                             }
  67
  68                             # Finish up
  69                             $mutex++;
  70                             cond_broadcast($mutex);
  71                             return ('okay');
  72                       }, $_);
  73     }
  74
  75     # Gather thread results
  76     my ($okay, $failures, $timeouts, $unknown) = (0, 0, 0, 0);
  77     for (1..$cnt) {
  78         my $rc = $threads[$_]->join();
  79         if (! $rc) {
  80             $failures++;
  81         } elsif ($rc =~ /^timed out/) {
  82             $timeouts++;
  83         } elsif ($rc eq 'okay') {
  84             $okay++;
  85         } else {
  86             $unknown++;
  87             print("# Unknown error: $rc\n");
  88         }
  89     }
  90
  91     if ($failures || $unknown || (($okay + $timeouts) != $cnt)) {
  92         print('not ok 1');
  93         my $too_few = $cnt - ($okay + $failures + $timeouts + $unknown);
  94         print(" - $too_few too few threads reported") if $too_few;
  95         print(" - $failures threads failed")          if $failures;
  96         print(" - $unknown unknown errors")           if $unknown;
  97         print(" - $timeouts threads timed out")       if $timeouts;
  98         print("\n");
  99
 100     } elsif ($timeouts) {
 101         # Frequently fails under MSWin32 due to deadlocking bug in Windows
 102         # hence test is TODO under MSWin32
 103         #   http://rt.perl.org/rt3/Public/Bug/Display.html?id=41574
 104         #   http://support.microsoft.com/kb/175332
 105         print('not ok 1');
 106         print(' # TODO - not reliable under MSWin32') if ($^O eq 'MSWin32');
 107         print(" - $timeouts threads timed out\n");
 108
 109     } else {
 110         print('ok 1');
 111         print(' # TODO - not reliable under MSWin32') if ($^O eq 'MSWin32');
 112         print("\n");
 113     }
 114 }
 115
 116 # EOF