Move threads from ext/ to dist/
[perl.git] / ext / threads-shared / t / cond.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 }
11
12 use ExtUtils::testlib;
13
14 my $Base = 0;
15 sub ok {
16     my ($id, $ok, $name) = @_;
17     $id += $Base;
18
19     # You have to do it this way or VMS will get confused.
20     if ($ok) {
21         print("ok $id - $name\n");
22     } else {
23         print("not ok $id - $name\n");
24         printf("# Failed test at line %d\n", (caller)[2]);
25     }
26
27     return ($ok);
28 }
29
30 BEGIN {
31     $| = 1;
32     print("1..32\n");   ### Number of tests that will be run ###
33 };
34
35 use threads;
36 use threads::shared;
37 ok(1, 1, 'Loaded');
38 $Base++;
39
40 ### Start of Testing ###
41
42 # test locking
43 {
44     my $lock : shared;
45     my $tr;
46
47     # test that a subthread can't lock until parent thread has unlocked
48
49     {
50         lock($lock);
51         ok(1, 1, "set first lock");
52         $tr = async {
53             lock($lock);
54             ok(3, 1, "set lock in subthread");
55         };
56         threads->yield;
57         ok(2, 1, "still got lock");
58     }
59     $tr->join;
60
61     $Base += 3;
62
63     # ditto with ref to thread
64
65     {
66         my $lockref = \$lock;
67         lock($lockref);
68         ok(1,1,"set first lockref");
69         $tr = async {
70             lock($lockref);
71             ok(3,1,"set lockref in subthread");
72         };
73         threads->yield;
74         ok(2,1,"still got lockref");
75     }
76     $tr->join;
77
78     $Base += 3;
79
80     # make sure recursive locks unlock at the right place
81     {
82         lock($lock);
83         ok(1,1,"set first recursive lock");
84         lock($lock);
85         threads->yield;
86         {
87             lock($lock);
88             threads->yield;
89         }
90         $tr = async {
91             lock($lock);
92             ok(3,1,"set recursive lock in subthread");
93         };
94         {
95             lock($lock);
96             threads->yield;
97             {
98                 lock($lock);
99                 threads->yield;
100                 lock($lock);
101                 threads->yield;
102             }
103         }
104         ok(2,1,"still got recursive lock");
105     }
106     $tr->join;
107
108     $Base += 3;
109
110     # Make sure a lock factory gives out fresh locks each time
111     # for both attribute and run-time shares
112
113     sub lock_factory1 { my $lock : shared; return \$lock; }
114     sub lock_factory2 { my $lock; share($lock); return \$lock; }
115
116     my (@locks1, @locks2);
117     push @locks1, lock_factory1() for 1..2;
118     push @locks1, lock_factory2() for 1..2;
119     push @locks2, lock_factory1() for 1..2;
120     push @locks2, lock_factory2() for 1..2;
121
122     ok(1,1,"lock factory: locking all locks");
123     lock $locks1[0];
124     lock $locks1[1];
125     lock $locks1[2];
126     lock $locks1[3];
127     ok(2,1,"lock factory: locked all locks");
128     $tr = async {
129         ok(3,1,"lock factory: child: locking all locks");
130         lock $locks2[0];
131         lock $locks2[1];
132         lock $locks2[2];
133         lock $locks2[3];
134         ok(4,1,"lock factory: child: locked all locks");
135     };
136     $tr->join;
137
138     $Base += 4;
139 }
140
141
142 # test cond_signal()
143 {
144     my $lock : shared;
145
146     sub foo {
147         lock($lock);
148         ok(1,1,"cond_signal: created first lock");
149         my $tr2 = threads->create(\&bar);
150         cond_wait($lock);
151         $tr2->join();
152         ok(5,1,"cond_signal: joined");
153     }
154
155     sub bar {
156         ok(2,1,"cond_signal: child before lock");
157         lock($lock);
158         ok(3,1,"cond_signal: child locked");
159         cond_signal($lock);
160         ok(4,1,"cond_signal: signalled");
161     }
162
163     my $tr  = threads->create(\&foo);
164     $tr->join();
165
166     $Base += 5;
167
168     # ditto, but with lockrefs
169
170     my $lockref = \$lock;
171     sub foo2 {
172         lock($lockref);
173         ok(1,1,"cond_signal: ref: created first lock");
174         my $tr2 = threads->create(\&bar2);
175         cond_wait($lockref);
176         $tr2->join();
177         ok(5,1,"cond_signal: ref: joined");
178     }
179
180     sub bar2 {
181         ok(2,1,"cond_signal: ref: child before lock");
182         lock($lockref);
183         ok(3,1,"cond_signal: ref: child locked");
184         cond_signal($lockref);
185         ok(4,1,"cond_signal: ref: signalled");
186     }
187
188     $tr  = threads->create(\&foo2);
189     $tr->join();
190
191     $Base += 5;
192 }
193
194
195 # test cond_broadcast()
196 {
197     my $counter : shared = 0;
198
199     # broad(N) forks off broad(N-1) and goes into a wait, in such a way
200     # that it's guaranteed to reach the wait before its child enters the
201     # locked region. When N reaches 0, the child instead does a
202     # cond_broadcast to wake all its ancestors.
203
204     sub broad {
205         my $n = shift;
206         my $th;
207         {
208             lock($counter);
209             if ($n > 0) {
210                 $counter++;
211                 $th = threads->create(\&broad, $n-1);
212                 cond_wait($counter);
213                 $counter += 10;
214             }
215             else {
216                 ok(1, $counter == 3, "cond_broadcast: all three waiting");
217                 cond_broadcast($counter);
218             }
219         }
220         $th->join if $th;
221     }
222
223     threads->create(\&broad, 3)->join;
224     ok(2, $counter == 33, "cond_broadcast: all three threads woken");
225
226     $Base += 2;
227
228
229     # ditto, but with refs and shared()
230
231     my $counter2 = 0;
232     share($counter2);
233     my $r = \$counter2;
234
235     sub broad2 {
236         my $n = shift;
237         my $th;
238         {
239             lock($r);
240             if ($n > 0) {
241                 $$r++;
242                 $th = threads->create(\&broad2, $n-1);
243                 cond_wait($r);
244                 $$r += 10;
245             }
246             else {
247                 ok(1, $$r == 3, "cond_broadcast: ref: all three waiting");
248                 cond_broadcast($r);
249             }
250         }
251         $th->join if $th;
252     }
253
254     threads->create(\&broad2, 3)->join;;
255     ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
256
257     $Base += 2;
258 }
259
260
261 # test warnings;
262 {
263     my $warncount = 0;
264     local $SIG{__WARN__} = sub { $warncount++ };
265
266     my $lock : shared;
267
268     cond_signal($lock);
269     ok(1, $warncount == 1, 'get warning on cond_signal');
270     cond_broadcast($lock);
271     ok(2, $warncount == 2, 'get warning on cond_broadcast');
272     no warnings 'threads';
273     cond_signal($lock);
274     ok(3, $warncount == 2, 'get no warning on cond_signal');
275     cond_broadcast($lock);
276     ok(4, $warncount == 2, 'get no warning on cond_broadcast');
277
278     $Base += 4;
279 }
280
281 exit(0);
282
283 # EOF