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