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