+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..31\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) = @_;
- my $not = '';
- $not = "not " unless $bool;
- print "${not}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;
# cond_broadcast to wake all its ancestors.
sub broad {
- my $n = shift;
- my $th;
- {
- lock($counter);
- if ($n > 0) {
- $counter++;
- $th = threads->new(\&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 $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->new(\&broad, 3)->join;
+ threads->create(\&broad, 3)->join;
ok(2, $counter == 33, "cond_broadcast: all three threads woken");
- print "# counter=$counter\n";
$Base += 2;
my $r = \$counter2;
sub broad2 {
- my $n = shift;
- my $th;
- {
- lock($r);
- if ($n > 0) {
- $$r++;
- $th = threads->new(\&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;
+ 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->new(\&broad2, 3)->join;;
+ threads->create(\&broad2, 3)->join;;
ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
- print "# counter=$$r\n";
$Base += 2;
-
}
-# test warnings;
+# test warnings;
{
my $warncount = 0;
local $SIG{__WARN__} = sub { $warncount++ };
$Base += 4;
}
+exit(0);
-
+# EOF