Commit | Line | Data |
7473853a |
1 | use strict; |
13c1b207 |
2 | use warnings; |
3 | |
89661126 |
4 | BEGIN { |
7473853a |
5 | use Config; |
6 | if (! $Config{'useithreads'}) { |
6c791b15 |
7 | print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); |
7473853a |
8 | exit(0); |
89661126 |
9 | } |
10 | } |
89661126 |
11 | |
7473853a |
12 | use ExtUtils::testlib; |
b5135157 |
13 | |
7473853a |
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 | } |
89661126 |
26 | |
7473853a |
27 | return ($ok); |
28 | } |
89661126 |
29 | |
7473853a |
30 | BEGIN { |
31 | $| = 1; |
05b59262 |
32 | print("1..32\n"); ### Number of tests that will be run ### |
7473853a |
33 | }; |
89661126 |
34 | |
7473853a |
35 | use threads; |
36 | use threads::shared; |
37 | ok(1, 1, 'Loaded'); |
38 | $Base++; |
ab335022 |
39 | |
7473853a |
40 | ### Start of Testing ### |
89661126 |
41 | |
ab335022 |
42 | # test locking |
ab335022 |
43 | { |
44 | my $lock : shared; |
45 | my $tr; |
46 | |
47 | # test that a subthread can't lock until parent thread has unlocked |
48 | |
49 | { |
7473853a |
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"); |
ab335022 |
58 | } |
59 | $tr->join; |
60 | |
61 | $Base += 3; |
62 | |
63 | # ditto with ref to thread |
64 | |
65 | { |
7473853a |
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"); |
ab335022 |
75 | } |
76 | $tr->join; |
77 | |
78 | $Base += 3; |
79 | |
80 | # make sure recursive locks unlock at the right place |
81 | { |
7473853a |
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"); |
ab335022 |
105 | } |
106 | $tr->join; |
107 | |
108 | $Base += 3; |
109 | |
7473853a |
110 | # Make sure a lock factory gives out fresh locks each time |
ab335022 |
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 { |
7473853a |
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"); |
ab335022 |
135 | }; |
136 | $tr->join; |
7473853a |
137 | |
ab335022 |
138 | $Base += 4; |
89661126 |
139 | } |
140 | |
894eec8b |
141 | |
ab335022 |
142 | # test cond_signal() |
ab335022 |
143 | { |
144 | my $lock : shared; |
145 | |
146 | sub foo { |
7473853a |
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"); |
ab335022 |
153 | } |
154 | |
155 | sub bar { |
7473853a |
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"); |
ab335022 |
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 { |
7473853a |
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"); |
ab335022 |
178 | } |
179 | |
180 | sub bar2 { |
7473853a |
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"); |
ab335022 |
186 | } |
187 | |
188 | $tr = threads->create(\&foo2); |
189 | $tr->join(); |
190 | |
191 | $Base += 5; |
ab335022 |
192 | } |
193 | |
194 | |
195 | # test cond_broadcast() |
ab335022 |
196 | { |
197 | my $counter : shared = 0; |
198 | |
07e9638f |
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. |
ab335022 |
203 | |
07e9638f |
204 | sub broad { |
7473853a |
205 | my $n = shift; |
206 | my $th; |
207 | { |
208 | lock($counter); |
209 | if ($n > 0) { |
210 | $counter++; |
878090d5 |
211 | $th = threads->create(\&broad, $n-1); |
7473853a |
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; |
ab335022 |
221 | } |
07e9638f |
222 | |
878090d5 |
223 | threads->create(\&broad, 3)->join; |
07e9638f |
224 | ok(2, $counter == 33, "cond_broadcast: all three threads woken"); |
ab335022 |
225 | |
07e9638f |
226 | $Base += 2; |
ab335022 |
227 | |
07e9638f |
228 | |
229 | # ditto, but with refs and shared() |
ab335022 |
230 | |
502fc48e |
231 | my $counter2 = 0; |
ab335022 |
232 | share($counter2); |
502fc48e |
233 | my $r = \$counter2; |
ab335022 |
234 | |
07e9638f |
235 | sub broad2 { |
7473853a |
236 | my $n = shift; |
237 | my $th; |
238 | { |
239 | lock($r); |
240 | if ($n > 0) { |
241 | $$r++; |
878090d5 |
242 | $th = threads->create(\&broad2, $n-1); |
7473853a |
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; |
ab335022 |
252 | } |
253 | |
878090d5 |
254 | threads->create(\&broad2, 3)->join;; |
07e9638f |
255 | ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken"); |
ab335022 |
256 | |
07e9638f |
257 | $Base += 2; |
ab335022 |
258 | } |
259 | |
7b13eb73 |
260 | |
7473853a |
261 | # test warnings; |
7b13eb73 |
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 | |
894eec8b |
278 | $Base += 4; |
279 | } |
280 | |
6c791b15 |
281 | exit(0); |
282 | |
7473853a |
283 | # EOF |