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