threads::shared 1.18
[perl.git] / 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         my $rc = $threads[$_]->join();
83         if (! $rc) {
84             $failures++;
85         } elsif ($rc =~ /^timed out/) {
86             $timeouts++;
87         } elsif ($rc eq 'okay') {
88             $okay++;
89         } else {
90             $unknown++;
91             print(STDERR "# Unknown error: $rc\n");
92         }
93     }
94
95     if ($failures || $unknown || (($okay + $timeouts) != $cnt)) {
96         print("not ok 1\n");
97         my $too_few = $cnt - ($okay + $failures + $timeouts + $unknown);
98         print(STDERR "# Test failed:\n");
99         print(STDERR "#\t$too_few too few threads reported\n") if $too_few;
100         print(STDERR "#\t$failures threads failed\n")          if $failures;
101         print(STDERR "#\t$unknown unknown errors\n")           if $unknown;
102         print(STDERR "#\t$timeouts threads timed out\n")       if $timeouts;
103
104     } elsif ($timeouts) {
105         # Frequently fails under MSWin32 due to deadlocking bug in Windows
106         # hence test is TODO under MSWin32
107         #   http://rt.perl.org/rt3/Public/Bug/Display.html?id=41574
108         #   http://support.microsoft.com/kb/175332
109         if ($^O eq 'MSWin32') {
110             print("not ok 1 # TODO - not reliable under MSWin32\n")
111         } else {
112             print("not ok 1\n");
113             print(STDERR "# Test failed: $timeouts threads timed out\n");
114         }
115
116     } else {
117         print('ok 1');
118         print(' # TODO - not reliable under MSWin32') if ($^O eq 'MSWin32');
119         print("\n");
120     }
121 }
122
123 # EOF