1#!perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7 $| = 1; 8 9 require Config; 10 if (!$Config::Config{useithreads}) { 11 print "1..0 # Skip: no ithreads\n"; 12 exit 0; 13 } 14 if ($ENV{PERL_CORE_MINITEST}) { 15 print "1..0 # Skip: no dynamic loading on miniperl, no threads\n"; 16 exit 0; 17 } 18 19 plan(10); 20} 21 22use strict; 23use warnings; 24use threads; 25 26# test that we don't get: 27# Attempt to free unreferenced scalar: SV 0x40173f3c 28fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads'); 29use threads; 30threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2; 31print "ok"; 32EOI 33 34#PR24660 35# test that we don't get: 36# Attempt to free unreferenced scalar: SV 0x814e0dc. 37fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads'); 38use threads; 39use Scalar::Util; 40my $data = "a"; 41my $obj = \$data; 42my $copy = $obj; 43Scalar::Util::weaken($copy); 44threads->create(sub { 1 })->join for (1..1); 45print "ok"; 46EOI 47 48#PR24663 49# test that we don't get: 50# panic: magic_killbackrefs. 51# Scalars leaked: 3 52fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads'); 53package Foo; 54sub new { bless {},shift } 55package main; 56use threads; 57use Scalar::Util qw(weaken); 58my $object = Foo->new; 59my $ref = $object; 60weaken $ref; 61threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems 62print "ok"; 63EOI 64 65#PR30333 - sort() crash with threads 66sub mycmp { length($b) <=> length($a) } 67 68sub do_sort_one_thread { 69 my $kid = shift; 70 print "# kid $kid before sort\n"; 71 my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z', 72 'hello', 's', 'thisisalongname', '1', '2', '3', 73 'abc', 'xyz', '1234567890', 'm', 'n', 'p' ); 74 75 for my $j (1..99999) { 76 for my $k (sort mycmp @list) {} 77 } 78 print "# kid $kid after sort, sleeping 1\n"; 79 sleep(1); 80 print "# kid $kid exit\n"; 81} 82 83sub do_sort_threads { 84 my $nthreads = shift; 85 my @kids = (); 86 for my $i (1..$nthreads) { 87 my $t = threads->create(\&do_sort_one_thread, $i); 88 print "# parent $$: continue\n"; 89 push(@kids, $t); 90 } 91 for my $t (@kids) { 92 print "# parent $$: waiting for join\n"; 93 $t->join(); 94 print "# parent $$: thread exited\n"; 95 } 96} 97 98do_sort_threads(2); # crashes 99ok(1); 100 101# Change 24643 made the mistake of assuming that CvCONST can only be true on 102# XSUBs. Somehow it can also end up on perl subs. 103fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs'); 104use constant x=>1; 105use threads; 106$SIG{__WARN__} = sub{}; 107async sub {}; 108print "ok"; 109EOI 110 111# From a test case by Tim Bunce in 112# http://www.nntp.perl.org/group/perl.perl5.porters/63123 113fresh_perl_is(<<'EOI', 'ok', { }, 'Ensure PL_linestr can be cloned'); 114use threads; 115print do 'op/threads_create.pl' || die $@; 116EOI 117 118 119TODO: { 120 no strict 'vars'; # Accessing $TODO from test.pl 121 local $TODO = 'refcount issues with threads'; 122 123# Scalars leaked: 1 124foreach my $BLOCK (qw(CHECK INIT)) { 125 fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block"); 126 use threads; 127 $BLOCK { threads->create(sub {})->join; } 128 print 'ok'; 129EOI 130} 131 132# Scalars leaked: 1 133fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138'); 134 use threads; 135 leak($x); 136 sub leak 137 { 138 local $x; 139 threads->create(sub {})->join(); 140 } 141 print 'ok'; 142EOI 143 144} # TODO 145 146# [perl #45053] Memory corruption with heavy module loading in threads 147# 148# run-time usage of newCONSTSUB (as done by the IO boot code) wasn't 149# thread-safe - got occasional coredumps or malloc corruption 150{ 151 local $SIG{__WARN__} = sub {}; # Ignore any thread creation failure warnings 152 my @t; 153 for (1..100) { 154 my $thr = threads->create( sub { require IO }); 155 last if !defined($thr); # Probably ran out of memory 156 push(@t, $thr); 157 } 158 $_->join for @t; 159 ok(1, '[perl #45053]'); 160} 161 162# EOF 163