+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..29\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]);
+ }
-use threads::shared;
+ return ($ok);
+}
-# We can't use the normal ok() type stuff here, as part of the test is
-# to check that the numbers get printed in the right order. Instead, we
-# set a 'base' number for each part of the test and specify the ok()
-# number as an offset from that base.
+BEGIN {
+ $| = 1;
+ print("1..32\n"); ### Number of tests that will be run ###
+};
-my $Base = 0;
+use threads;
+use threads::shared;
+ok(1, 1, 'Loaded');
+$Base++;
-sub ok {
- my ($offset, $bool, $text) = @_;
- print "not " unless $bool;
- print "ok ", $Base + $offset, " - $text\n";
-}
+### 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");
+ 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;
# 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");
+ 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;
# 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");
+ 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
+ # 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; }
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");
+ 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;
}
-# test cond_signal()
+# 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");
+ 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");
+ 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);
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");
+ 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");
+ 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;
- sub waiter {
- lock($counter);
- $counter++;
- cond_wait($counter);
- $counter += 10;
+ # 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;
}
- my $tr1 = threads->new(\&waiter);
- my $tr2 = threads->new(\&waiter);
- my $tr3 = threads->new(\&waiter);
+ threads->create(\&broad, 3)->join;
+ ok(2, $counter == 33, "cond_broadcast: all three threads woken");
- while (1) {
- lock $counter;
- # make sure all 3 threads are waiting
- next unless $counter == 3;
- cond_broadcast $counter;
- last;
- }
- $tr1->join(); $tr2->join(); $tr3->join();
- ok(1, $counter == 33, "cond_broadcast: all three threads woken");
- print "# counter=$counter\n";
+ $Base += 2;
- $Base += 1;
- # ditto with refs and shared()
+ # ditto, but with refs and shared()
- my $counter2;
+ my $counter2 = 0;
share($counter2);
- my $r = \$counter2;
-
- sub waiter2 {
- lock($r);
- $$r++;
- cond_wait($r);
- $$r += 10;
+ 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;
}
- $tr1 = threads->new(\&waiter2);
- $tr2 = threads->new(\&waiter2);
- $tr3 = threads->new(\&waiter2);
-
- while (1) {
- lock($r);
- # make sure all 3 threads are waiting
- next unless $$r == 3;
- cond_broadcast $r;
- last;
- }
- $tr1->join(); $tr2->join(); $tr3->join();
- ok(1, $$r == 33, "cond_broadcast: ref: all three threads woken");
- print "# counter=$$r\n";
-
- $Base += 1;
+ threads->create(\&broad2, 3)->join;;
+ ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
+ $Base += 2;
}
-# test warnings;
+# test warnings;
{
my $warncount = 0;
local $SIG{__WARN__} = sub { $warncount++ };
my $lock : shared;
- cond_wait($lock);
- ok(1, $warncount == 1, 'get warning on cond_wait');
+ cond_signal($lock);
+ ok(1, $warncount == 1, 'get warning on cond_signal');
cond_broadcast($lock);
- ok(2, $warncount == 2, 'get warning on cond_wait');
+ ok(2, $warncount == 2, 'get warning on cond_broadcast');
no warnings 'threads';
- cond_wait($lock);
- ok(3, $warncount == 2, 'get no warning on cond_wait');
+ cond_signal($lock);
+ ok(3, $warncount == 2, 'get no warning on cond_signal');
cond_broadcast($lock);
- ok(4, $warncount == 2, 'get no warning on cond_wait');
+ ok(4, $warncount == 2, 'get no warning on cond_broadcast');
$Base += 4;
}
-
-
+# EOF
https://perl5.git.perl.org / perl5.git / blobdiff