5 if ($ENV{'PERL_CORE'}){
7 unshift @INC, '../lib';
10 if (! $Config{'useithreads'}) {
11 print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
16 use ExtUtils::testlib;
20 my ($id, $ok, $name) = @_;
23 # You have to do it this way or VMS will get confused.
25 print("ok $id - $name\n");
27 print("not ok $id - $name\n");
28 printf("# Failed test at line %d\n", (caller)[2]);
36 print("1..82\n"); ### Number of tests that will be run ###
44 ### Start of Testing ###
51 # test that a subthread can't lock until parent thread has unlocked
55 ok(1, 1, "set first lock");
58 ok(3, 1, "set lock in subthread");
61 ok(2, 1, "still got lock");
67 # ditto with ref to thread
72 ok(1,1,"set first lockref");
75 ok(3,1,"set lockref in subthread");
78 ok(2,1,"still got lockref");
84 # make sure recursive locks unlock at the right place
87 ok(1,1,"set first recursive lock");
96 ok(3,1,"set recursive lock in subthread");
108 ok(2,1,"still got recursive lock");
114 # Make sure a lock factory gives out fresh locks each time
115 # for both attribute and run-time shares
117 sub lock_factory1 { my $lock : shared; return \$lock; }
118 sub lock_factory2 { my $lock; share($lock); return \$lock; }
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;
126 ok(1,1,"lock factory: locking all locks");
131 ok(2,1,"lock factory: locked all locks");
133 ok(3,1,"lock factory: child: locking all locks");
138 ok(4,1,"lock factory: child: locked all locks");
152 ok(1,1,"cond_signal: created first lock");
153 my $tr2 = threads->create(\&bar);
156 ok(5,1,"cond_signal: joined");
160 ok(2,1,"cond_signal: child before lock");
162 ok(3,1,"cond_signal: child locked");
164 ok(4,1,"cond_signal: signalled");
167 my $tr = threads->create(\&foo);
172 # ditto, but with lockrefs
174 my $lockref = \$lock;
177 ok(1,1,"cond_signal: ref: created first lock");
178 my $tr2 = threads->create(\&bar2);
181 ok(5,1,"cond_signal: ref: joined");
185 ok(2,1,"cond_signal: ref: child before lock");
187 ok(3,1,"cond_signal: ref: child locked");
188 cond_signal($lockref);
189 ok(4,1,"cond_signal: ref: signalled");
192 $tr = threads->create(\&foo2);
199 # test cond_broadcast()
201 my $counter : shared = 0;
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.
215 $th = threads->new(\&broad, $n-1);
220 ok(1, $counter == 3, "cond_broadcast: all three waiting");
221 cond_broadcast($counter);
227 threads->new(\&broad, 3)->join;
228 ok(2, $counter == 33, "cond_broadcast: all three threads woken");
233 # ditto, but with refs and shared()
246 $th = threads->new(\&broad2, $n-1);
251 ok(1, $$r == 3, "cond_broadcast: ref: all three waiting");
258 threads->new(\&broad2, 3)->join;;
259 ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
268 local $SIG{__WARN__} = sub { $warncount++ };
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';
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');
295 my $thread = threads->create(sub {
302 while ($mutex != $_) {
306 cond_broadcast($mutex);
309 push(@threads, $thread);
313 my $result = $threads[$_-1]->join();
314 ok($_, defined($result) && ("$result" eq '1000001'), "stress test - iter $_");