5 if ($ENV{'PERL_CORE'}){
7 unshift @INC, '../lib';
10 unless ($Config{'useithreads'}) {
11 print "1..0 # Skip: no useithreads\n";
16 use ExtUtils::testlib;
18 BEGIN { print "1..17\n" };
28 lock $test_id; # make print and increment atomic
30 # You have to do it this way or VMS will get confused.
31 print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
33 printf "# Failed test at line %d\n", (caller)[2] unless $ok;
39 ok(1, "# Skipped: @_");
46 my $retval = threads->create(sub { return ("hi") })->join();
47 ok($retval eq 'hi', "Check basic returnvalue");
50 my ($thread) = threads->create(sub { return (1,2,3) });
51 my @retval = $thread->join();
52 ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
55 my $retval = threads->create(sub { return [1] })->join();
56 ok($retval->[0] == 1,"Check that a array ref works",);
59 my $retval = threads->create(sub { return { foo => "bar" }})->join();
60 ok($retval->{foo} eq 'bar',"Check that hash refs work");
63 my $retval = threads->create( sub {
64 open(my $fh, "+>threadtest") || die $!;
68 ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
69 print $retval "test2\n";
71 # ok(<$retval> eq "test\n");
77 my $retval = threads->create(sub { return $_[0]}, \$test)->join();
78 ok($$retval eq 'hi','');
83 my $retval = threads->create(sub { return $_[0]}, \$test)->join();
84 ok($$retval eq 'hi','');
86 ok($$retval eq 'foo','');
95 return $foo{bar} = \$foo;
100 # We parse ps output so this is OS-dependent.
101 if ($^O eq 'linux') {
102 # First modify $0 in a subthread.
103 print "# mainthread: \$0 = $0\n";
104 threads->create( sub {
105 print "# subthread: \$0 = $0\n";
107 print "# subthread: \$0 = $0\n" } )->join;
108 print "# mainthread: \$0 = $0\n";
109 print "# pid = $$\n";
110 if (open PS, "ps -f |") { # Note: must work in (all) systems.
111 my ($sawpid, $sawexe);
117 if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
125 ok($sawpid && $sawexe, 'altering $0 is effective');
127 skip("\$0 check: did not see pid $$ in 'ps -f |'");
130 skip("\$0 check: opening 'ps -f |' failed: $!");
133 skip("\$0 check: only on Linux");
137 my $t = threads->create(sub {});
139 threads->create(sub {})->join();
140 eval { $t->join(); };
141 ok(($@ =~ /Thread already joined/), "Double join works");
142 eval { $t->detach(); };
143 ok(($@ =~ /Cannot detach a joined thread/), "Detach joined thread");
147 my $t = threads->create(sub {});
149 threads->create(sub {})->join();
150 eval { $t->detach(); };
151 ok(($@ =~ /Thread already detached/), "Double detach works");
152 eval { $t->join(); };
153 ok(($@ =~ /Cannot join a detached thread/), "Join detached thread");
157 # The "use IO::File" is not actually used for anything; its only
158 # purpose is to incite a lot of calls to newCONSTSUB. See the p5p
159 # archives for the thread "maint@20974 or before broke mp2 ithreads test".
161 # this coredumped between #20930 and #21000
162 $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2;