1use strict; 2use warnings; 3 4BEGIN { 5 require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); 6 7 use Config; 8 if (! $Config{'useithreads'}) { 9 skip_all(q/Perl not compiled with 'useithreads'/); 10 } 11} 12 13use ExtUtils::testlib; 14use Data::Dumper; 15 16use threads; 17 18BEGIN { 19 if (! eval 'use threads::shared; 1') { 20 skip_all('threads::shared not available'); 21 } 22 23 $| = 1; 24 print("1..35\n"); ### Number of tests that will be run ### 25}; 26 27print("ok 1 - Loaded\n"); 28 29### Start of Testing ### 30 31sub content { 32 print shift; 33 return shift; 34} 35{ 36 my $t = threads->create(\&content, "ok 2\n", "ok 3\n", 1..1000); 37 print $t->join(); 38} 39{ 40 my $lock : shared; 41 my $t; 42 { 43 lock($lock); 44 $t = threads->create(sub { lock($lock); print "ok 5\n"}); 45 print "ok 4\n"; 46 } 47 $t->join(); 48} 49 50sub dorecurse { 51 my $val = shift; 52 my $ret; 53 print $val; 54 if(@_) { 55 $ret = threads->create(\&dorecurse, @_); 56 $ret->join; 57 } 58} 59{ 60 my $t = threads->create(\&dorecurse, map { "ok $_\n" } 6..10); 61 $t->join(); 62} 63 64{ 65 # test that sleep lets other thread run 66 my $t = threads->create(\&dorecurse, "ok 11\n"); 67 threads->yield; # help out non-preemptive thread implementations 68 sleep 1; 69 print "ok 12\n"; 70 $t->join(); 71} 72{ 73 my $lock : shared; 74 sub islocked { 75 lock($lock); 76 my $val = shift; 77 my $ret; 78 print $val; 79 if (@_) { 80 $ret = threads->create(\&islocked, shift); 81 } 82 return $ret; 83 } 84my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n"); 85$t->join->join; 86} 87 88 89 90sub testsprintf { 91 my $testno = shift; 92 my $same = sprintf( "%0.f", $testno); 93 return $testno eq $same; 94} 95 96sub threaded { 97 my ($string, $string_end) = @_; 98 99 # Do the match, saving the output in appropriate variables 100 $string =~ /(.*)(is)(.*)/; 101 # Yield control, allowing the other thread to fill in the match variables 102 threads->yield(); 103 # Examine the match variable contents; on broken perls this fails 104 return $3 eq $string_end; 105} 106 107 108{ 109 curr_test(15); 110 111 my $thr1 = threads->create(\&testsprintf, 15); 112 my $thr2 = threads->create(\&testsprintf, 16); 113 114 my $short = "This is a long string that goes on and on."; 115 my $shorte = " a long string that goes on and on."; 116 my $long = "This is short."; 117 my $longe = " short."; 118 my $foo = "This is bar bar bar."; 119 my $fooe = " bar bar bar."; 120 my $thr3 = new threads \&threaded, $short, $shorte; 121 my $thr4 = new threads \&threaded, $long, $longe; 122 my $thr5 = new threads \&testsprintf, 19; 123 my $thr6 = new threads \&testsprintf, 20; 124 my $thr7 = new threads \&threaded, $foo, $fooe; 125 126 ok($thr1->join()); 127 ok($thr2->join()); 128 ok($thr3->join()); 129 ok($thr4->join()); 130 ok($thr5->join()); 131 ok($thr6->join()); 132 ok($thr7->join()); 133} 134 135# test that 'yield' is importable 136 137package Test1; 138 139use threads 'yield'; 140yield; 141main::ok(1); 142 143package main; 144 145 146# test async 147 148{ 149 my $th = async {return 1 }; 150 ok($th); 151 ok($th->join()); 152} 153{ 154 # There is a miniscule chance this test case may falsely fail 155 # since it tests using rand() 156 my %rand : shared; 157 rand(10); 158 threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25; 159 $_->join foreach threads->list; 160 ok((keys %rand >= 23), "Check that rand() is randomized in new threads") 161 or diag Dumper(\%rand); 162} 163 164# bugid #24165 165 166run_perl(prog => 'use threads 2.21;' . 167 'sub a{threads->create(shift)} $t = a sub{};' . 168 '$t->tid; $t->join; $t->tid', 169 nolib => ($ENV{PERL_CORE}) ? 0 : 1, 170 switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]); 171is($?, 0, 'coredump in global destruction'); 172 173# Attempt to free unreferenced scalar... 174fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via scalar'); 175 use threads; 176 my $test = sub {}; 177 threads->create($test)->join(); 178 print 'ok'; 179EOI 180 181# Attempt to free unreferenced scalar... 182fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via $_[0]'); 183 use threads; 184 sub thr { threads->new($_[0]); } 185 thr(sub { })->join; 186 print 'ok'; 187EOI 188 189# [perl #45053] Memory corruption from eval return in void context 190fresh_perl_is(<<'EOI', 'ok', { }, 'void eval return'); 191 use threads; 192 threads->create(sub { eval '1' }); 193 $_->join() for threads->list; 194 print 'ok'; 195EOI 196 197# test CLONE_SKIP() functionality 198SKIP: { 199 skip('CLONE_SKIP not implemented in Perl < 5.8.7', 5) if ($] < 5.008007); 200 201 my %c : shared; 202 my %d : shared; 203 204 # --- 205 206 package A; 207 sub CLONE_SKIP { $c{"A-$_[0]"}++; 1; } 208 sub DESTROY { $d{"A-". ref $_[0]}++ } 209 210 package A1; 211 our @ISA = qw(A); 212 sub CLONE_SKIP { $c{"A1-$_[0]"}++; 1; } 213 sub DESTROY { $d{"A1-". ref $_[0]}++ } 214 215 package A2; 216 our @ISA = qw(A1); 217 218 # --- 219 220 package B; 221 sub CLONE_SKIP { $c{"B-$_[0]"}++; 0; } 222 sub DESTROY { $d{"B-" . ref $_[0]}++ } 223 224 package B1; 225 our @ISA = qw(B); 226 sub CLONE_SKIP { $c{"B1-$_[0]"}++; 1; } 227 sub DESTROY { $d{"B1-" . ref $_[0]}++ } 228 229 package B2; 230 our @ISA = qw(B1); 231 232 # --- 233 234 package C; 235 sub CLONE_SKIP { $c{"C-$_[0]"}++; 1; } 236 sub DESTROY { $d{"C-" . ref $_[0]}++ } 237 238 package C1; 239 our @ISA = qw(C); 240 sub CLONE_SKIP { $c{"C1-$_[0]"}++; 0; } 241 sub DESTROY { $d{"C1-" . ref $_[0]}++ } 242 243 package C2; 244 our @ISA = qw(C1); 245 246 # --- 247 248 package D; 249 sub DESTROY { $d{"D-" . ref $_[0]}++ } 250 251 package D1; 252 our @ISA = qw(D); 253 254 package main; 255 256 { 257 my @objs; 258 for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) { 259 push @objs, bless [], $class; 260 } 261 262 sub f { 263 my $depth = shift; 264 my $cloned = ""; # XXX due to recursion, doesn't get initialized 265 $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs; 266 is($cloned, ($depth ? '00010001111' : '11111111111'), 267 "objs clone skip at depth $depth"); 268 threads->create( \&f, $depth+1)->join if $depth < 2; 269 @objs = (); 270 } 271 f(0); 272 } 273 274 curr_test(curr_test()+2); 275 ok(eq_hash(\%c, 276 { 277 qw( 278 A-A 2 279 A1-A1 2 280 A1-A2 2 281 B-B 2 282 B1-B1 2 283 B1-B2 2 284 C-C 2 285 C1-C1 2 286 C1-C2 2 287 ) 288 }), 289 "counts of calls to CLONE_SKIP"); 290 ok(eq_hash(\%d, 291 { 292 qw( 293 A-A 1 294 A1-A1 1 295 A1-A2 1 296 B-B 3 297 B1-B1 1 298 B1-B2 1 299 C-C 1 300 C1-C1 3 301 C1-C2 3 302 D-D 3 303 D-D1 3 304 ) 305 }), 306 "counts of calls to DESTROY"); 307} 308 309# Bug 73330 - Apply magic to arg to ->object() 310{ 311 my @tids :shared; 312 313 my $thr = threads->create(sub { 314 lock(@tids); 315 push(@tids, threads->tid()); 316 cond_signal(@tids); 317 }); 318 319 { 320 lock(@tids); 321 cond_wait(@tids) while (! @tids); 322 } 323 324 ok(threads->object($_), 'Got threads object') foreach (@tids); 325 326 $thr->join(); 327} 328 329exit(0); 330 331# EOF 332