add Porting/core-cpan-diff
[perl.git] / ext / threads-shared / t / cond.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 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     }
30
31     return ($ok);
32 }
33
34 BEGIN {
35     $| = 1;
36     print("1..32\n");   ### Number of tests that will be run ###
37 };
38
39 use threads;
40 use threads::shared;
41 ok(1, 1, 'Loaded');
42 $Base++;
43
44 ### Start of Testing ###
45
46 # test locking
47 {
48     my $lock : shared;
49     my $tr;
50
51     # test that a subthread can't lock until parent thread has unlocked
52
53     {
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");
62     }
63     $tr->join;
64
65     $Base += 3;
66
67     # ditto with ref to thread
68
69     {
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");
79     }
80     $tr->join;
81
82     $Base += 3;
83
84     # make sure recursive locks unlock at the right place
85     {
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");
109     }
110     $tr->join;
111
112     $Base += 3;
113
114     # Make sure a lock factory gives out fresh locks each time
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 {
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");
139     };
140     $tr->join;
141
142     $Base += 4;
143 }
144
145
146 # test cond_signal()
147 {
148     my $lock : shared;
149
150     sub foo {
151         lock($lock);
152         ok(1,1,"cond_signal: created first lock");
153         my $tr2 = threads->create(\&bar);
154         cond_wait($lock);
155         $tr2->join();
156         ok(5,1,"cond_signal: joined");
157     }
158
159     sub bar {
160         ok(2,1,"cond_signal: child before lock");
161         lock($lock);
162         ok(3,1,"cond_signal: child locked");
163         cond_signal($lock);
164         ok(4,1,"cond_signal: signalled");
165     }
166
167     my $tr  = threads->create(\&foo);
168     $tr->join();
169
170     $Base += 5;
171
172     # ditto, but with lockrefs
173
174     my $lockref = \$lock;
175     sub foo2 {
176         lock($lockref);
177         ok(1,1,"cond_signal: ref: created first lock");
178         my $tr2 = threads->create(\&bar2);
179         cond_wait($lockref);
180         $tr2->join();
181         ok(5,1,"cond_signal: ref: joined");
182     }
183
184     sub bar2 {
185         ok(2,1,"cond_signal: ref: child before lock");
186         lock($lockref);
187         ok(3,1,"cond_signal: ref: child locked");
188         cond_signal($lockref);
189         ok(4,1,"cond_signal: ref: signalled");
190     }
191
192     $tr  = threads->create(\&foo2);
193     $tr->join();
194
195     $Base += 5;
196 }
197
198
199 # test cond_broadcast()
200 {
201     my $counter : shared = 0;
202
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.
207
208     sub broad {
209         my $n = shift;
210         my $th;
211         {
212             lock($counter);
213             if ($n > 0) {
214                 $counter++;
215                 $th = threads->create(\&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;
225     }
226
227     threads->create(\&broad, 3)->join;
228     ok(2, $counter == 33, "cond_broadcast: all three threads woken");
229
230     $Base += 2;
231
232
233     # ditto, but with refs and shared()
234
235     my $counter2 = 0;
236     share($counter2);
237     my $r = \$counter2;
238
239     sub broad2 {
240         my $n = shift;
241         my $th;
242         {
243             lock($r);
244             if ($n > 0) {
245                 $$r++;
246                 $th = threads->create(\&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;
256     }
257
258     threads->create(\&broad2, 3)->join;;
259     ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
260
261     $Base += 2;
262 }
263
264
265 # test warnings;
266 {
267     my $warncount = 0;
268     local $SIG{__WARN__} = sub { $warncount++ };
269
270     my $lock : shared;
271
272     cond_signal($lock);
273     ok(1, $warncount == 1, 'get warning on cond_signal');
274     cond_broadcast($lock);
275     ok(2, $warncount == 2, 'get warning on cond_broadcast');
276     no warnings 'threads';
277     cond_signal($lock);
278     ok(3, $warncount == 2, 'get no warning on cond_signal');
279     cond_broadcast($lock);
280     ok(4, $warncount == 2, 'get no warning on cond_broadcast');
281
282     $Base += 4;
283 }
284
285 exit(0);
286
287 # EOF