+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 useithreads\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);
}
}
use ExtUtils::testlib;
-use strict;
-BEGIN { print "1..12\n" };
+
use threads;
-use threads::shared;
-my $test_id = 1;
-share($test_id);
-use Devel::Peek qw(Dump);
+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);
+ 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 =~ /^(linux|dec_osf)$/) {
- # First modify $0 in a subthread.
- print "# mainthread: \$0 = $0\n";
- threads->new( 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++;
+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+$$\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");
+}
+
+{
+ my $t = threads->create(sub {});
+ $t->join();
+ threads->create(sub {})->join();
+ eval { $t->join(); };
+ ok(($@ =~ /Thread already joined/), "Double join works");
+ eval { $t->detach(); };
+ ok(($@ =~ /Cannot detach a joined thread/), "Detach joined thread");
}
{
- my $t = threads->new(sub {});
+ my $t = threads->create(sub {});
+ $t->detach();
+ threads->create(sub {})->join();
+ eval { $t->detach(); };
+ ok(($@ =~ /Thread already detached/), "Double detach works");
+ eval { $t->join(); };
+ ok(($@ =~ /Cannot join a detached thread/), "Join detached thread");
+}
+
+{
+ # 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
+ $_->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 $x = threads->new(sub {});
- $x->join;
- eval {
- $t->join;
- };
- my $ok = 0;
- $ok++ if($@ =~/Thread already joined/);
- ok($ok, "Double join works");
}
+
+{
+ 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
projects / p5sagit/p5-mst-13.2.git / blobdiff