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