Commit | Line | Data |
385d56e4 |
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 | use threads; |
19 | use threads::shared; |
20 | |
21 | BEGIN { |
22 | if (($] < 5.008002) && ($threads::shared::VERSION < 0.92)) { |
23 | print("1..0 # Skip: Needs threads::shared 0.92 or later\n"); |
24 | exit(0); |
25 | } |
26 | |
27 | $| = 1; |
28 | print("1..74\n"); ### Number of tests that will be run ### |
29 | }; |
30 | |
31 | my $TEST = 1; |
32 | share($TEST); |
33 | |
34 | ok(1, 'Loaded'); |
35 | |
36 | sub ok { |
37 | my ($ok, $name) = @_; |
38 | |
39 | lock($TEST); |
40 | my $id = $TEST++; |
41 | |
42 | # You have to do it this way or VMS will get confused. |
43 | if ($ok) { |
44 | print("ok $id - $name\n"); |
45 | } else { |
46 | print("not ok $id - $name\n"); |
47 | printf("# Failed test at line %d\n", (caller)[2]); |
48 | } |
49 | |
50 | return ($ok); |
51 | } |
52 | |
53 | |
54 | ### Start of Testing ### |
55 | |
56 | # Tests freeing the Perl interperter for each thread |
57 | # See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details |
58 | |
59 | my $COUNT; |
60 | share($COUNT); |
61 | my %READY; |
62 | share(%READY); |
63 | |
64 | # Init a thread |
65 | sub th_start { |
66 | my $tid = threads->tid(); |
67 | ok($tid, "Thread $tid started"); |
68 | |
69 | # Create next thread |
70 | if ($tid < 17) { |
71 | my $next = 'th' . ($tid+1); |
72 | my $th = threads->create($next); |
73 | } else { |
74 | # Last thread signals first |
75 | th_signal(1); |
76 | } |
77 | th_wait(); |
78 | } |
79 | |
80 | # Thread terminating |
81 | sub th_done { |
82 | my $tid = threads->tid(); |
83 | |
84 | lock($COUNT); |
85 | $COUNT++; |
86 | cond_signal($COUNT); |
87 | |
88 | ok($tid, "Thread $tid done"); |
89 | } |
90 | |
91 | # Wait until signalled by another thread |
92 | sub th_wait |
93 | { |
94 | my $tid = threads->tid(); |
95 | |
96 | lock(%READY); |
97 | while (! exists($READY{$tid})) { |
98 | cond_wait(%READY); |
99 | } |
100 | my $other = delete($READY{$tid}); |
101 | ok($tid, "Thread $tid received signal from $other"); |
102 | } |
103 | |
104 | # Signal another thread to go |
105 | sub th_signal |
106 | { |
107 | my $other = shift; |
108 | my $tid = threads->tid(); |
109 | |
110 | ok($tid, "Thread $tid signalling $other"); |
111 | |
112 | lock(%READY); |
113 | $READY{$other} = $tid; |
114 | cond_broadcast(%READY); |
115 | } |
116 | |
117 | ##### |
118 | |
119 | sub th1 { |
120 | th_start(); |
121 | |
122 | threads->detach(); |
123 | |
124 | th_signal(2); |
125 | th_signal(6); |
126 | th_signal(10); |
127 | th_signal(14); |
128 | |
129 | th_done(); |
130 | } |
131 | |
132 | sub th2 { |
133 | th_start(); |
134 | threads->detach(); |
135 | th_signal(4); |
136 | th_done(); |
137 | } |
138 | |
139 | sub th6 { |
140 | th_start(); |
141 | threads->detach(); |
142 | th_signal(8); |
143 | th_done(); |
144 | } |
145 | |
146 | sub th10 { |
147 | th_start(); |
148 | threads->detach(); |
149 | th_signal(12); |
150 | th_done(); |
151 | } |
152 | |
153 | sub th14 { |
154 | th_start(); |
155 | threads->detach(); |
156 | th_signal(16); |
157 | th_done(); |
158 | } |
159 | |
160 | sub th4 { |
161 | th_start(); |
162 | threads->detach(); |
163 | th_signal(3); |
164 | th_done(); |
165 | } |
166 | |
167 | sub th8 { |
168 | th_start(); |
169 | threads->detach(); |
170 | th_signal(7); |
171 | th_done(); |
172 | } |
173 | |
174 | sub th12 { |
175 | th_start(); |
176 | threads->detach(); |
177 | th_signal(13); |
178 | th_done(); |
179 | } |
180 | |
181 | sub th16 { |
182 | th_start(); |
183 | threads->detach(); |
184 | th_signal(17); |
185 | th_done(); |
186 | } |
187 | |
188 | sub th3 { |
189 | my $other = 5; |
190 | |
191 | th_start(); |
192 | threads->detach(); |
193 | th_signal($other); |
194 | threads->yield(); |
195 | sleep(1); |
196 | my $ret = threads->object($other)->join(); |
197 | ok($ret == $other, "Thread $other returned $ret"); |
198 | th_done(); |
199 | } |
200 | |
201 | sub th5 { |
202 | th_start(); |
203 | th_done(); |
204 | return (threads->tid()); |
205 | } |
206 | |
207 | |
208 | sub th7 { |
209 | my $other = 9; |
210 | |
211 | th_start(); |
212 | threads->detach(); |
213 | th_signal($other); |
214 | my $ret = threads->object($other)->join(); |
215 | ok($ret == $other, "Thread $other returned $ret"); |
216 | th_done(); |
217 | } |
218 | |
219 | sub th9 { |
220 | th_start(); |
221 | threads->yield(); |
222 | sleep(1); |
223 | th_done(); |
224 | return (threads->tid()); |
225 | } |
226 | |
227 | |
228 | sub th13 { |
229 | my $other = 11; |
230 | |
231 | th_start(); |
232 | threads->detach(); |
233 | th_signal($other); |
234 | threads->yield(); |
235 | sleep(1); |
236 | my $ret = threads->object($other)->join(); |
237 | ok($ret == $other, "Thread $other returned $ret"); |
238 | th_done(); |
239 | } |
240 | |
241 | sub th11 { |
242 | th_start(); |
243 | th_done(); |
244 | return (threads->tid()); |
245 | } |
246 | |
247 | |
248 | sub th17 { |
249 | my $other = 15; |
250 | |
251 | th_start(); |
252 | threads->detach(); |
253 | th_signal($other); |
254 | my $ret = threads->object($other)->join(); |
255 | ok($ret == $other, "Thread $other returned $ret"); |
256 | th_done(); |
257 | } |
258 | |
259 | sub th15 { |
260 | th_start(); |
261 | threads->yield(); |
262 | sleep(1); |
263 | th_done(); |
264 | return (threads->tid()); |
265 | } |
266 | |
267 | |
268 | |
269 | |
270 | |
271 | |
272 | TEST_STARTS_HERE: |
273 | { |
274 | $COUNT = 0; |
275 | threads->create('th1'); |
276 | { |
277 | lock($COUNT); |
278 | while ($COUNT < 17) { |
279 | cond_wait($COUNT); |
280 | } |
281 | } |
282 | threads->yield(); |
283 | sleep(1); |
284 | } |
285 | ok($COUNT == 17, "Done - $COUNT threads"); |
286 | |
287 | # EOF |