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