+use strict;
use warnings;
BEGIN {
- chdir 't' if -d 't';
- push @INC ,'../lib';
- require Config; import Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no threads\n";
- exit 0;
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ unshift @INC, '../lib';
+ }
+ use Config;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
-$|++;
-print "1..5\n";
-use strict;
+use ExtUtils::testlib;
-use threads;
+my $Base = 0;
+sub ok {
+ my ($id, $ok, $name) = @_;
+ $id += $Base;
+
+ # You have to do it this way or VMS will get confused.
+ if ($ok) {
+ print("ok $id - $name\n");
+ } else {
+ print("not ok $id - $name\n");
+ printf("# Failed test at line %d\n", (caller)[2]);
+ }
+
+ return ($ok);
+}
+BEGIN {
+ $| = 1;
+ print("1..32\n"); ### Number of tests that will be run ###
+};
+
+use threads;
use threads::shared;
+ok(1, 1, 'Loaded');
+$Base++;
+
+### Start of Testing ###
+
+# test locking
+{
+ my $lock : shared;
+ my $tr;
+
+ # test that a subthread can't lock until parent thread has unlocked
+
+ {
+ lock($lock);
+ ok(1, 1, "set first lock");
+ $tr = async {
+ lock($lock);
+ ok(3, 1, "set lock in subthread");
+ };
+ threads->yield;
+ ok(2, 1, "still got lock");
+ }
+ $tr->join;
-my $lock : shared;
+ $Base += 3;
-sub foo {
- lock($lock);
- print "ok 1\n";
- my $tr2 = threads->create(\&bar);
- cond_wait($lock);
- $tr2->join();
- print "ok 5\n";
+ # ditto with ref to thread
+
+ {
+ my $lockref = \$lock;
+ lock($lockref);
+ ok(1,1,"set first lockref");
+ $tr = async {
+ lock($lockref);
+ ok(3,1,"set lockref in subthread");
+ };
+ threads->yield;
+ ok(2,1,"still got lockref");
+ }
+ $tr->join;
+
+ $Base += 3;
+
+ # make sure recursive locks unlock at the right place
+ {
+ lock($lock);
+ ok(1,1,"set first recursive lock");
+ lock($lock);
+ threads->yield;
+ {
+ lock($lock);
+ threads->yield;
+ }
+ $tr = async {
+ lock($lock);
+ ok(3,1,"set recursive lock in subthread");
+ };
+ {
+ lock($lock);
+ threads->yield;
+ {
+ lock($lock);
+ threads->yield;
+ lock($lock);
+ threads->yield;
+ }
+ }
+ ok(2,1,"still got recursive lock");
+ }
+ $tr->join;
+
+ $Base += 3;
+
+ # Make sure a lock factory gives out fresh locks each time
+ # for both attribute and run-time shares
+
+ sub lock_factory1 { my $lock : shared; return \$lock; }
+ sub lock_factory2 { my $lock; share($lock); return \$lock; }
+
+ my (@locks1, @locks2);
+ push @locks1, lock_factory1() for 1..2;
+ push @locks1, lock_factory2() for 1..2;
+ push @locks2, lock_factory1() for 1..2;
+ push @locks2, lock_factory2() for 1..2;
+
+ ok(1,1,"lock factory: locking all locks");
+ lock $locks1[0];
+ lock $locks1[1];
+ lock $locks1[2];
+ lock $locks1[3];
+ ok(2,1,"lock factory: locked all locks");
+ $tr = async {
+ ok(3,1,"lock factory: child: locking all locks");
+ lock $locks2[0];
+ lock $locks2[1];
+ lock $locks2[2];
+ lock $locks2[3];
+ ok(4,1,"lock factory: child: locked all locks");
+ };
+ $tr->join;
+
+ $Base += 4;
}
-sub bar {
- print "ok 2\n";
- lock($lock);
- print "ok 3\n";
+
+# test cond_signal()
+{
+ my $lock : shared;
+
+ sub foo {
+ lock($lock);
+ ok(1,1,"cond_signal: created first lock");
+ my $tr2 = threads->create(\&bar);
+ cond_wait($lock);
+ $tr2->join();
+ ok(5,1,"cond_signal: joined");
+ }
+
+ sub bar {
+ ok(2,1,"cond_signal: child before lock");
+ lock($lock);
+ ok(3,1,"cond_signal: child locked");
+ cond_signal($lock);
+ ok(4,1,"cond_signal: signalled");
+ }
+
+ my $tr = threads->create(\&foo);
+ $tr->join();
+
+ $Base += 5;
+
+ # ditto, but with lockrefs
+
+ my $lockref = \$lock;
+ sub foo2 {
+ lock($lockref);
+ ok(1,1,"cond_signal: ref: created first lock");
+ my $tr2 = threads->create(\&bar2);
+ cond_wait($lockref);
+ $tr2->join();
+ ok(5,1,"cond_signal: ref: joined");
+ }
+
+ sub bar2 {
+ ok(2,1,"cond_signal: ref: child before lock");
+ lock($lockref);
+ ok(3,1,"cond_signal: ref: child locked");
+ cond_signal($lockref);
+ ok(4,1,"cond_signal: ref: signalled");
+ }
+
+ $tr = threads->create(\&foo2);
+ $tr->join();
+
+ $Base += 5;
+}
+
+
+# test cond_broadcast()
+{
+ my $counter : shared = 0;
+
+ # broad(N) forks off broad(N-1) and goes into a wait, in such a way
+ # that it's guaranteed to reach the wait before its child enters the
+ # locked region. When N reaches 0, the child instead does a
+ # cond_broadcast to wake all its ancestors.
+
+ sub broad {
+ my $n = shift;
+ my $th;
+ {
+ lock($counter);
+ if ($n > 0) {
+ $counter++;
+ $th = threads->create(\&broad, $n-1);
+ cond_wait($counter);
+ $counter += 10;
+ }
+ else {
+ ok(1, $counter == 3, "cond_broadcast: all three waiting");
+ cond_broadcast($counter);
+ }
+ }
+ $th->join if $th;
+ }
+
+ threads->create(\&broad, 3)->join;
+ ok(2, $counter == 33, "cond_broadcast: all three threads woken");
+
+ $Base += 2;
+
+
+ # ditto, but with refs and shared()
+
+ my $counter2 = 0;
+ share($counter2);
+ my $r = \$counter2;
+
+ sub broad2 {
+ my $n = shift;
+ my $th;
+ {
+ lock($r);
+ if ($n > 0) {
+ $$r++;
+ $th = threads->create(\&broad2, $n-1);
+ cond_wait($r);
+ $$r += 10;
+ }
+ else {
+ ok(1, $$r == 3, "cond_broadcast: ref: all three waiting");
+ cond_broadcast($r);
+ }
+ }
+ $th->join if $th;
+ }
+
+ threads->create(\&broad2, 3)->join;;
+ ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
+
+ $Base += 2;
+}
+
+
+# test warnings;
+{
+ my $warncount = 0;
+ local $SIG{__WARN__} = sub { $warncount++ };
+
+ my $lock : shared;
+
+ cond_signal($lock);
+ ok(1, $warncount == 1, 'get warning on cond_signal');
+ cond_broadcast($lock);
+ ok(2, $warncount == 2, 'get warning on cond_broadcast');
+ no warnings 'threads';
cond_signal($lock);
- print "ok 4\n";
+ ok(3, $warncount == 2, 'get no warning on cond_signal');
+ cond_broadcast($lock);
+ ok(4, $warncount == 2, 'get no warning on cond_broadcast');
+
+ $Base += 4;
}
-my $tr = threads->create(\&foo);
-$tr->join();
+exit(0);
+# EOF
projects / p5sagit/p5-mst-13.2.git / blobdiff