1use strict; 2use warnings; 3 4BEGIN { 5 use Config; 6 if (! $Config{'useithreads'}) { 7 print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); 8 exit(0); 9 } 10} 11 12use ExtUtils::testlib; 13 14use threads; 15 16BEGIN { 17 if (! eval 'use threads::shared; 1') { 18 print("1..0 # SKIP threads::shared not available\n"); 19 exit(0); 20 } 21 22 $| = 1; 23 print("1..20\n"); ### Number of tests that will be run ### 24}; 25 26my $TEST; 27BEGIN { 28 share($TEST); 29 $TEST = 1; 30} 31 32ok(1, 'Loaded'); 33 34sub ok { 35 my ($ok, $name) = @_; 36 37 lock($TEST); 38 my $id = $TEST++; 39 40 # You have to do it this way or VMS will get confused. 41 if ($ok) { 42 print("ok $id - $name\n"); 43 } else { 44 print("not ok $id - $name\n"); 45 printf("# Failed test at line %d\n", (caller)[2]); 46 } 47 48 return ($ok); 49} 50 51sub skip { 52 ok(1, '# SKIP ' . $_[0]); 53} 54 55 56### Start of Testing ### 57 58{ 59 my $retval = threads->create(sub { return ("hi") })->join(); 60 ok($retval eq 'hi', "Check basic returnvalue"); 61} 62{ 63 my ($thread) = threads->create(sub { return (1,2,3) }); 64 my @retval = $thread->join(); 65 ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,''); 66} 67{ 68 my $retval = threads->create(sub { return [1] })->join(); 69 ok($retval->[0] == 1,"Check that a array ref works",); 70} 71{ 72 my $retval = threads->create(sub { return { foo => "bar" }})->join(); 73 ok($retval->{foo} eq 'bar',"Check that hash refs work"); 74} 75{ 76 my $retval = threads->create( sub { 77 open(my $fh, "+>threadtest") || die $!; 78 print $fh "test\n"; 79 return $fh; 80 })->join(); 81 ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval"); 82 print $retval "test2\n"; 83 close($retval); 84 unlink("threadtest"); 85} 86{ 87 my $test = "hi"; 88 my $retval = threads->create(sub { return $_[0]}, \$test)->join(); 89 ok($$retval eq 'hi',''); 90} 91{ 92 my $test = "hi"; 93 share($test); 94 my $retval = threads->create(sub { return $_[0]}, \$test)->join(); 95 ok($$retval eq 'hi',''); 96 $test = "foo"; 97 ok($$retval eq 'foo',''); 98} 99{ 100 my %foo; 101 share(%foo); 102 threads->create(sub { 103 my $foo; 104 share($foo); 105 $foo = "thread1"; 106 return $foo{bar} = \$foo; 107 })->join(); 108 ok(1,""); 109} 110 111# We parse ps output so this is OS-dependent. 112if ($^O eq 'linux') { 113 # First modify $0 in a subthread. 114 #print "# mainthread: \$0 = $0\n"; 115 threads->create(sub{ #print "# subthread: \$0 = $0\n"; 116 $0 = "foobar"; 117 #print "# subthread: \$0 = $0\n" 118 })->join; 119 #print "# mainthread: \$0 = $0\n"; 120 #print "# pid = $$\n"; 121 if (open PS, "ps -f |") { # Note: must work in (all) systems. 122 my ($sawpid, $sawexe); 123 while (<PS>) { 124 chomp; 125 #print "# [$_]\n"; 126 if (/^\s*\S+\s+$$\s/) { 127 $sawpid++; 128 if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces. 129 $sawexe++; 130 } 131 last; 132 } 133 } 134 close PS or die; 135 if ($sawpid) { 136 ok($sawpid && $sawexe, 'altering $0 is effective'); 137 } else { 138 skip("\$0 check: did not see pid $$ in 'ps -f |'"); 139 } 140 } else { 141 skip("\$0 check: opening 'ps -f |' failed: $!"); 142 } 143} else { 144 skip("\$0 check: only on Linux"); 145} 146 147{ 148 my $t = threads->create(sub {}); 149 $t->join(); 150 threads->create(sub {})->join(); 151 eval { $t->join(); }; 152 ok(($@ =~ /Thread already joined/), "Double join works"); 153 eval { $t->detach(); }; 154 ok(($@ =~ /Cannot detach a joined thread/), "Detach joined thread"); 155} 156 157{ 158 my $t = threads->create(sub {}); 159 $t->detach(); 160 threads->create(sub {})->join(); 161 eval { $t->detach(); }; 162 ok(($@ =~ /Thread already detached/), "Double detach works"); 163 eval { $t->join(); }; 164 ok(($@ =~ /Cannot join a detached thread/), "Join detached thread"); 165} 166 167{ 168 # The "use IO::File" is not actually used for anything; its only purpose 169 # is incite a lot of calls to newCONSTSUB. See the p5p archives for 170 # the thread "maint@20974 or before broke mp2 ithreads test". 171 use IO::File; 172 # This coredumped between #20930 and #21000 173 $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2; 174} 175 176{ 177 my $go : shared = 0; 178 179 my $t = threads->create( sub { 180 lock($go); 181 cond_wait($go) until $go; 182 }); 183 184 my $joiner = threads->create(sub { $_[0]->join }, $t); 185 186 threads->yield(); 187 sleep 1; 188 eval { $t->join; }; 189 ok(($@ =~ /^Thread already joined at/)?1:0, "Join pending join"); 190 191 { lock($go); $go = 1; cond_signal($go); } 192 $joiner->join; 193} 194 195{ 196 my $go : shared = 0; 197 my $t = threads->create( sub { 198 eval { threads->self->join; }; 199 ok(($@ =~ /^Cannot join self/), "Join self"); 200 lock($go); $go = 1; cond_signal($go); 201 }); 202 203 { lock ($go); cond_wait($go) until $go; } 204 $t->join; 205} 206 207{ 208 my $go : shared = 0; 209 my $t = threads->create( sub { 210 lock($go); cond_wait($go) until $go; 211 }); 212 my $joiner = threads->create(sub { $_[0]->join; }, $t); 213 214 threads->yield(); 215 sleep 1; 216 eval { $t->detach }; 217 ok(($@ =~ /^Cannot detach a joined thread at/)?1:0, "Detach pending join"); 218 219 { lock($go); $go = 1; cond_signal($go); } 220 $joiner->join; 221} 222 223exit(0); 224 225# EOF 226