1use strict; 2use warnings; 3 4BEGIN { 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 16use ExtUtils::testlib; 17 18BEGIN { 19 $| = 1; 20 print("1..1\n"); ### Number of tests that will be run ### 21}; 22 23use threads; 24use 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 147exit(0); 148 149# EOF 150