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) = @_;
30 print "not " unless $bool;
31 print "ok ", $Base + $offset, " - $text\n";
40 # test that a subthread can't lock until parent thread has unlocked
44 ok(1,1,"set first lock");
47 ok(3,1,"set lock in subthread");
50 ok(2,1,"still got lock");
56 # ditto with ref to thread
61 ok(1,1,"set first lockref");
64 ok(3,1,"set lockref in subthread");
67 ok(2,1,"still got lockref");
73 # make sure recursive locks unlock at the right place
76 ok(1,1,"set first recursive lock");
85 ok(3,1,"set recursive lock in subthread");
97 ok(2,1,"still got recursive lock");
103 # Make sure a lock factory gives out fresh locks each time
104 # for both attribute and run-time shares
106 sub lock_factory1 { my $lock : shared; return \$lock; }
107 sub lock_factory2 { my $lock; share($lock); return \$lock; }
109 my (@locks1, @locks2);
110 push @locks1, lock_factory1() for 1..2;
111 push @locks1, lock_factory2() for 1..2;
112 push @locks2, lock_factory1() for 1..2;
113 push @locks2, lock_factory2() for 1..2;
115 ok(1,1,"lock factory: locking all locks");
120 ok(2,1,"lock factory: locked all locks");
122 ok(3,1,"lock factory: child: locking all locks");
127 ok(4,1,"lock factory: child: locked all locks");
141 ok(1,1,"cond_signal: created first lock");
142 my $tr2 = threads->create(\&bar);
145 ok(5,1,"cond_signal: joined");
149 ok(2,1,"cond_signal: child before lock");
151 ok(3,1,"cond_signal: child locked");
153 ok(4,1,"cond_signal: signalled");
156 my $tr = threads->create(\&foo);
161 # ditto, but with lockrefs
163 my $lockref = \$lock;
166 ok(1,1,"cond_signal: ref: created first lock");
167 my $tr2 = threads->create(\&bar2);
170 ok(5,1,"cond_signal: ref: joined");
174 ok(2,1,"cond_signal: ref: child before lock");
176 ok(3,1,"cond_signal: ref: child locked");
177 cond_signal($lockref);
178 ok(4,1,"cond_signal: ref: signalled");
181 $tr = threads->create(\&foo2);
189 # test cond_broadcast()
192 my $counter : shared = 0;
194 # broad(N) forks off broad(N-1) and goes into a wait, in such a way
195 # that it's guaranteed to reach the wait before its child enters the
196 # locked region. When N reaches 0, the child instead does a
197 # cond_broadcast to wake all its ancestors.
206 $th = threads->new(\&broad, $n-1);
211 ok(1, $counter == 3, "cond_broadcast: all three waiting");
212 cond_broadcast($counter);
218 threads->new(\&broad, 3)->join;
219 ok(2, $counter == 33, "cond_broadcast: all three threads woken");
220 print "# counter=$counter\n";
225 # ditto, but with refs and shared()
238 $th = threads->new(\&broad2, $n-1);
243 ok(1, $$r == 3, "cond_broadcast: ref: all three waiting");
250 threads->new(\&broad2, 3)->join;;
251 ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
252 print "# counter=$$r\n";
262 local $SIG{__WARN__} = sub { $warncount++ };
267 ok(1, $warncount == 1, 'get warning on cond_signal');
268 cond_broadcast($lock);
269 ok(2, $warncount == 2, 'get warning on cond_broadcast');
270 no warnings 'threads';
272 ok(3, $warncount == 2, 'get no warning on cond_signal');
273 cond_broadcast($lock);
274 ok(4, $warncount == 2, 'get no warning on cond_broadcast');