6 require Config; import Config;
7 unless ($Config{'useithreads'}) {
8 print "1..0 # Skip: no threads\n";
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.
29 my ($offset, $bool, $text) = @_;
31 $not = "not " unless $bool;
32 print "${not}ok " . ($Base + $offset) . " - $text\n";
41 # test that a subthread can't lock until parent thread has unlocked
45 ok(1,1,"set first lock");
48 ok(3,1,"set lock in subthread");
51 ok(2,1,"still got lock");
57 # ditto with ref to thread
62 ok(1,1,"set first lockref");
65 ok(3,1,"set lockref in subthread");
68 ok(2,1,"still got lockref");
74 # make sure recursive locks unlock at the right place
77 ok(1,1,"set first recursive lock");
86 ok(3,1,"set recursive lock in subthread");
98 ok(2,1,"still got recursive lock");
104 # Make sure a lock factory gives out fresh locks each time
105 # for both attribute and run-time shares
107 sub lock_factory1 { my $lock : shared; return \$lock; }
108 sub lock_factory2 { my $lock; share($lock); return \$lock; }
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;
116 ok(1,1,"lock factory: locking all locks");
121 ok(2,1,"lock factory: locked all locks");
123 ok(3,1,"lock factory: child: locking all locks");
128 ok(4,1,"lock factory: child: locked all locks");
142 ok(1,1,"cond_signal: created first lock");
143 my $tr2 = threads->create(\&bar);
146 ok(5,1,"cond_signal: joined");
150 ok(2,1,"cond_signal: child before lock");
152 ok(3,1,"cond_signal: child locked");
154 ok(4,1,"cond_signal: signalled");
157 my $tr = threads->create(\&foo);
162 # ditto, but with lockrefs
164 my $lockref = \$lock;
167 ok(1,1,"cond_signal: ref: created first lock");
168 my $tr2 = threads->create(\&bar2);
171 ok(5,1,"cond_signal: ref: joined");
175 ok(2,1,"cond_signal: ref: child before lock");
177 ok(3,1,"cond_signal: ref: child locked");
178 cond_signal($lockref);
179 ok(4,1,"cond_signal: ref: signalled");
182 $tr = threads->create(\&foo2);
190 # test cond_broadcast()
193 my $counter : shared = 0;
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.
207 $th = threads->new(\&broad, $n-1);
212 ok(1, $counter == 3, "cond_broadcast: all three waiting");
213 cond_broadcast($counter);
219 threads->new(\&broad, 3)->join;
220 ok(2, $counter == 33, "cond_broadcast: all three threads woken");
221 print "# counter=$counter\n";
226 # ditto, but with refs and shared()
239 $th = threads->new(\&broad2, $n-1);
244 ok(1, $$r == 3, "cond_broadcast: ref: all three waiting");
251 threads->new(\&broad2, 3)->join;;
252 ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
253 print "# counter=$$r\n";
263 local $SIG{__WARN__} = sub { $warncount++ };
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';
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');