Move threads::shared from ext/ to dist/
[perl.git] / 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