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