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