This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #78494] Pipes cause threads to hang on join()
[perl5.git] / t / op / threads.t
CommitLineData
09576c7d
JH
1#!perl
2
f935b2f6
SB
3BEGIN {
4 chdir 't' if -d 't';
996dc718 5 @INC = '../lib';
9708a845 6 require './test.pl';
57690963 7 $| = 1;
f935b2f6 8
09576c7d
JH
9 require Config;
10 if (!$Config::Config{useithreads}) {
11 print "1..0 # Skip: no ithreads\n";
12 exit 0;
f935b2f6 13 }
6765206c
NC
14 if ($ENV{PERL_CORE_MINITEST}) {
15 print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
16 exit 0;
f935b2f6 17 }
09576c7d 18
2e0cfa16 19 plan(24);
f935b2f6 20}
09576c7d
JH
21
22use strict;
23use warnings;
6765206c 24use threads;
f935b2f6
SB
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;
878090d5 30threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
f935b2f6
SB
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);
878090d5 44threads->create(sub { 1 })->join for (1..1);
f935b2f6
SB
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;
878090d5 61threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems
f935b2f6
SB
62print "ok";
63EOI
9850bf21
RH
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) {
878090d5 87 my $t = threads->create(\&do_sort_one_thread, $i);
9850bf21
RH
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);
cfae286e
NC
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
db4997f0
NC
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;
e81465be 115print do 'op/threads_create.pl' || die $@;
db4997f0 116EOI
9708a845 117
9708a845
JH
118
119# Scalars leaked: 1
120foreach my $BLOCK (qw(CHECK INIT)) {
121 fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block");
122 use threads;
123 $BLOCK { threads->create(sub {})->join; }
124 print 'ok';
125EOI
126}
127
128# Scalars leaked: 1
129fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138');
130 use threads;
131 leak($x);
132 sub leak
133 {
134 local $x;
135 threads->create(sub {})->join();
136 }
137 print 'ok';
138EOI
139
9708a845 140
f0d3b40c
JH
141# [perl #45053] Memory corruption with heavy module loading in threads
142#
143# run-time usage of newCONSTSUB (as done by the IO boot code) wasn't
144# thread-safe - got occasional coredumps or malloc corruption
145{
76eabe0a 146 local $SIG{__WARN__} = sub {}; # Ignore any thread creation failure warnings
f0d3b40c 147 my @t;
76eabe0a
JH
148 for (1..100) {
149 my $thr = threads->create( sub { require IO });
150 last if !defined($thr); # Probably ran out of memory
151 push(@t, $thr);
152 }
f0d3b40c
JH
153 $_->join for @t;
154 ok(1, '[perl #45053]');
155}
156
f708cfc1
NC
157sub matchit {
158 is (ref $_[1], "Regexp");
159 like ($_[0], $_[1]);
160}
161
162threads->new(\&matchit, "Pie", qr/pie/i)->join();
163
164# tests in threads don't get counted, so
165curr_test(curr_test() + 2);
166
1db36481
DM
167
168# the seen_evals field of a regexp was getting zeroed on clone, so
93f09d7b 169# within a thread it didn't know that a regex object contained a 'safe'
1db36481
DM
170# re_eval expression, so it later died with 'Eval-group not allowed' when
171# you tried to interpolate the object
172
173sub safe_re {
174 my $re = qr/(?{1})/; # this is literal, so safe
175 eval { "a" =~ /$re$re/ }; # interpolating safe values, so safe
176 ok($@ eq "", 'clone seen-evals');
177}
178threads->new(\&safe_re)->join();
179
180# tests in threads don't get counted, so
181curr_test(curr_test() + 1);
182
1dffc4d1
NC
183# This used to crash in 5.10.0 [perl #64954]
184
185undef *a;
186threads->new(sub {})->join;
187pass("undefing a typeglob doesn't cause a crash during cloning");
1db36481 188
7c76c2a0 189
7c76c2a0
JH
190# Test we don't get:
191# panic: del_backref during global destruction.
27bca322
FC
192# when returning a non-closure sub from a thread and subsequently starting
193# a new thread.
194fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic [perl #70748]');
7c76c2a0
JH
195use threads;
196sub foo { return (sub { }); }
197my $bar = threads->create(\&foo)->join();
198threads->create(sub { })->join();
199print "ok";
200EOI
201
27bca322 202# Another, more reliable test for the same del_backref bug:
e4295668
NC
203fresh_perl_is(
204 <<' EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)'
27bca322
FC
205 use threads;
206 push @bar, threads->create(sub{sub{}})->join() for 1...10;
207 print "ok";
208 EOJ
209);
210
211# Simple closure-returning test: At least this case works (though it
212# leaks), and we don't want to break it.
e4295668 213fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure');
27bca322
FC
214use threads;
215print create threads sub {
e4295668 216 my $x = 'foo';
27bca322
FC
217 sub{sub{$x}}
218}=>->join->()()
219 //"undef"
220EOJ
7c76c2a0 221
3287f6c3
NC
222# At the point of thread creation, $h{1} is on the temps stack.
223# The weak reference $a, however, is visible from the symbol table.
224fresh_perl_is(<<'EOI', 'ok', { }, 'Test for 34394ecd06e704e9');
225 use threads;
226 %h = (1, 2);
227 use Scalar::Util 'weaken';
228 $a = \$h{1};
229 weaken($a);
230 delete $h{1} && threads->create(sub {}, shift)->join();
231 print 'ok';
232EOI
233
f7abe70b
NC
234# This will fail in "interesting" ways if stashes in clone_params is not
235# initialised correctly.
236fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE reference/, { }, 'RT #73046');
237 use strict;
238 use threads;
239
240 sub foo::bar;
241
242 my %h = (1, *{$::{'foo::'}}{HASH});
243 *{$::{'foo::'}} = {};
244
245 threads->create({}, delete $h{1})->join();
246
247 print "end";
248EOI
249
d08d57ef
NC
250fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_');
251 use threads;
252 my %h = (1, []);
253 use Scalar::Util 'weaken';
254 my $a = $h{1};
255 weaken($a);
256 delete $h{1} && threads->create(sub {}, shift)->join();
257 print 'ok';
258EOI
259
05d04d9c
NC
260{
261 my $got;
262 sub stuff {
263 my $a;
264 if (@_) {
265 $a = "Leakage";
266 threads->create(\&stuff)->join();
267 } else {
268 is ($a, undef, 'RT #73086 - clone used to clone active pads');
269 }
270 }
271
272 stuff(1);
273
274 curr_test(curr_test() + 1);
275}
276
adf8f095
NC
277{
278 my $got;
279 sub more_stuff {
280 my $a;
281 $::b = \$a;
282 if (@_) {
283 $a = "More leakage";
284 threads->create(\&more_stuff)->join();
285 } else {
286 is ($a, undef, 'Just special casing lexicals in ?{ ... }');
287 }
288 }
289
290 more_stuff(1);
291
292 curr_test(curr_test() + 1);
293}
294
04518cc3
NC
295# Test from Jerry Hedden, reduced by him from Object::InsideOut's tests.
296fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt during CLONE');
297use strict;
298use warnings;
299
300use threads;
301
302{
303 package My::Obj;
304 use Scalar::Util 'weaken';
305
306 my %reg;
307
308 sub new
309 {
310 # Create object with ID = 1
311 my $class = shift;
312 my $id = 1;
313 my $obj = bless(\do{ my $scalar = $id; }, $class);
314
315 # Save weak copy of object for reference during cloning
316 weaken($reg{$id} = $obj);
317
318 # Return object
319 return $obj;
320 }
321
322 # Return the internal ID of the object
323 sub id
324 {
325 my $obj = shift;
326 return $$obj;
327 }
328
329 # During cloning 'look' at the object
330 sub CLONE {
331 foreach my $id (keys(%reg)) {
332 # This triggers SvREFCNT_inc() then SvREFCNT_dec() on the referant.
333 my $obj = $reg{$id};
334 }
335 }
336}
337
338# Create object in 'main' thread
339my $obj = My::Obj->new();
340my $id = $obj->id();
341die "\$id is '$id'" unless $id == 1;
342
343# Access object in thread
344threads->create(
345 sub {
346 print $obj->id() == 1 ? "ok\n" : "not ok '" . $obj->id() . "'\n";
347 }
348)->join();
349
350EOI
351
2e0cfa16
FC
352# [perl #78494] Pipes shared between threads block when closed
353watchdog 10;
354{
355 my $perl = which_perl;
356 $perl = qq'"$perl"' if $perl =~ /\s/;
357 open(my $OUT, "|$perl") || die("ERROR: $!");
358 threads->create(sub { })->join;
359 ok(1, "Pipes shared between threads do not block when closed");
360}
361
9708a845 362# EOF