unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
use ExtUtils::testlib;
-BEGIN { print "1..17\n" };
use threads;
-use threads::shared;
-my $test_id = 1;
-share($test_id);
+BEGIN {
+ eval {
+ require threads::shared;
+ import threads::shared;
+ };
+ if ($@ || ! $threads::shared::threads_shared) {
+ print("1..0 # Skip: threads::shared not available\n");
+ exit(0);
+ }
+
+ $| = 1;
+ print("1..20\n"); ### Number of tests that will be run ###
+};
+
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
+
+ok(1, 'Loaded');
sub ok {
my ($ok, $name) = @_;
- lock $test_id; # make print and increment atomic
+ lock($TEST);
+ my $id = $TEST++;
# You have to do it this way or VMS will get confused.
- print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
+ if ($ok) {
+ print("ok $id - $name\n");
+ } else {
+ print("not ok $id - $name\n");
+ printf("# Failed test at line %d\n", (caller)[2]);
+ }
- printf "# Failed test at line %d\n", (caller)[2] unless $ok;
- $test_id++;
- return $ok;
+ return ($ok);
}
sub skip {
- ok(1, "# Skipped: @_");
+ ok(1, '# Skipped: ' . $_[0]);
}
-ok(1,"");
+### Start of Testing ###
{
my $retval = threads->create(sub { return ("hi") })->join();
}
{
my $retval = threads->create( sub {
- open(my $fh, "+>threadtest") || die $!;
- print $fh "test\n";
- return $fh;
+ open(my $fh, "+>threadtest") || die $!;
+ print $fh "test\n";
+ return $fh;
})->join();
ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
print $retval "test2\n";
-# seek($retval,0,0);
-# ok(<$retval> eq "test\n");
close($retval);
unlink("threadtest");
}
my %foo;
share(%foo);
threads->create(sub {
- my $foo;
- share($foo);
- $foo = "thread1";
- return $foo{bar} = \$foo;
+ my $foo;
+ share($foo);
+ $foo = "thread1";
+ return $foo{bar} = \$foo;
})->join();
ok(1,"");
}
# We parse ps output so this is OS-dependent.
if ($^O eq 'linux') {
- # First modify $0 in a subthread.
- print "# mainthread: \$0 = $0\n";
- threads->create( sub {
- print "# subthread: \$0 = $0\n";
- $0 = "foobar";
- print "# subthread: \$0 = $0\n" } )->join;
- print "# mainthread: \$0 = $0\n";
- print "# pid = $$\n";
- if (open PS, "ps -f |") { # Note: must work in (all) systems.
- my ($sawpid, $sawexe);
- while (<PS>) {
- chomp;
- print "# [$_]\n";
- if (/^\S+\s+$$\s/) {
- $sawpid++;
- if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
- $sawexe++;
+ # First modify $0 in a subthread.
+ #print "# mainthread: \$0 = $0\n";
+ threads->create(sub{ #print "# subthread: \$0 = $0\n";
+ $0 = "foobar";
+ #print "# subthread: \$0 = $0\n"
+ })->join;
+ #print "# mainthread: \$0 = $0\n";
+ #print "# pid = $$\n";
+ if (open PS, "ps -f |") { # Note: must work in (all) systems.
+ my ($sawpid, $sawexe);
+ while (<PS>) {
+ chomp;
+ #print "# [$_]\n";
+ if (/^\s*\S+\s+$$\s/) {
+ $sawpid++;
+ if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
+ $sawexe++;
+ }
+ last;
+ }
+ }
+ close PS or die;
+ if ($sawpid) {
+ ok($sawpid && $sawexe, 'altering $0 is effective');
+ } else {
+ skip("\$0 check: did not see pid $$ in 'ps -f |'");
}
- last;
- }
- }
- close PS or die;
- if ($sawpid) {
- ok($sawpid && $sawexe, 'altering $0 is effective');
} else {
- skip("\$0 check: did not see pid $$ in 'ps -f |'");
+ skip("\$0 check: opening 'ps -f |' failed: $!");
}
- } else {
- skip("\$0 check: opening 'ps -f |' failed: $!");
- }
} else {
- skip("\$0 check: only on Linux");
+ skip("\$0 check: only on Linux");
}
{
}
{
- # The "use IO::File" is not actually used for anything; its only
- # purpose is to incite a lot of calls to newCONSTSUB. See the p5p
- # archives for the thread "maint@20974 or before broke mp2 ithreads test".
+ # The "use IO::File" is not actually used for anything; its only purpose
+ # is incite a lot of calls to newCONSTSUB. See the p5p archives for
+ # the thread "maint@20974 or before broke mp2 ithreads test".
use IO::File;
- # this coredumped between #20930 and #21000
+ # This coredumped between #20930 and #21000
$_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2;
}
+{
+ my $go : shared = 0;
+
+ my $t = threads->create( sub {
+ lock($go);
+ cond_wait($go) until $go;
+ });
+
+ my $joiner = threads->create(sub { $_[0]->join }, $t);
+
+ threads->yield();
+ sleep 1;
+ eval { $t->join; };
+ ok(($@ =~ /^Thread already joined at/)?1:0, "Join pending join");
+
+ { lock($go); $go = 1; cond_signal($go); }
+ $joiner->join;
+}
+
+{
+ my $go : shared = 0;
+ my $t = threads->create( sub {
+ eval { threads->self->join; };
+ ok(($@ =~ /^Cannot join self/), "Join self");
+ lock($go); $go = 1; cond_signal($go);
+ });
+
+ { lock ($go); cond_wait($go) until $go; }
+ $t->join;
+}
+
+{
+ my $go : shared = 0;
+ my $t = threads->create( sub {
+ lock($go); cond_wait($go) until $go;
+ });
+ my $joiner = threads->create(sub { $_[0]->join; }, $t);
+
+ threads->yield();
+ sleep 1;
+ eval { $t->detach };
+ ok(($@ =~ /^Cannot detach a joined thread at/)?1:0, "Detach pending join");
+
+ { lock($go); $go = 1; cond_signal($go); }
+ $joiner->join;
+}
+
+# EOF