Commit | Line | Data |
---|---|---|
09576c7d JH |
1 | #!perl |
2 | ||
f935b2f6 SB |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
996dc718 | 5 | @INC = '../lib'; |
9708a845 | 6 | require './test.pl'; |
57690963 | 7 | $| = 1; |
f935b2f6 | 8 | |
9c8416b2 | 9 | skip_all_without_config('useithreads'); |
62e452a4 | 10 | skip_all_if_miniperl("no dynamic loading on miniperl, no threads"); |
09576c7d | 11 | |
f03015cd | 12 | plan(27); |
f935b2f6 | 13 | } |
09576c7d JH |
14 | |
15 | use strict; | |
16 | use warnings; | |
6765206c | 17 | use threads; |
f935b2f6 SB |
18 | |
19 | # test that we don't get: | |
20 | # Attempt to free unreferenced scalar: SV 0x40173f3c | |
21 | fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads'); | |
22 | use threads; | |
878090d5 | 23 | threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2; |
f935b2f6 SB |
24 | print "ok"; |
25 | EOI | |
26 | ||
27 | #PR24660 | |
28 | # test that we don't get: | |
29 | # Attempt to free unreferenced scalar: SV 0x814e0dc. | |
30 | fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads'); | |
31 | use threads; | |
32 | use Scalar::Util; | |
33 | my $data = "a"; | |
34 | my $obj = \$data; | |
35 | my $copy = $obj; | |
36 | Scalar::Util::weaken($copy); | |
878090d5 | 37 | threads->create(sub { 1 })->join for (1..1); |
f935b2f6 SB |
38 | print "ok"; |
39 | EOI | |
40 | ||
41 | #PR24663 | |
42 | # test that we don't get: | |
43 | # panic: magic_killbackrefs. | |
44 | # Scalars leaked: 3 | |
45 | fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads'); | |
46 | package Foo; | |
47 | sub new { bless {},shift } | |
48 | package main; | |
49 | use threads; | |
50 | use Scalar::Util qw(weaken); | |
51 | my $object = Foo->new; | |
52 | my $ref = $object; | |
53 | weaken $ref; | |
878090d5 | 54 | threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems |
f935b2f6 SB |
55 | print "ok"; |
56 | EOI | |
9850bf21 RH |
57 | |
58 | #PR30333 - sort() crash with threads | |
59 | sub mycmp { length($b) <=> length($a) } | |
60 | ||
61 | sub do_sort_one_thread { | |
62 | my $kid = shift; | |
63 | print "# kid $kid before sort\n"; | |
64 | my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z', | |
65 | 'hello', 's', 'thisisalongname', '1', '2', '3', | |
66 | 'abc', 'xyz', '1234567890', 'm', 'n', 'p' ); | |
67 | ||
68 | for my $j (1..99999) { | |
69 | for my $k (sort mycmp @list) {} | |
70 | } | |
71 | print "# kid $kid after sort, sleeping 1\n"; | |
72 | sleep(1); | |
73 | print "# kid $kid exit\n"; | |
74 | } | |
75 | ||
76 | sub do_sort_threads { | |
77 | my $nthreads = shift; | |
78 | my @kids = (); | |
79 | for my $i (1..$nthreads) { | |
878090d5 | 80 | my $t = threads->create(\&do_sort_one_thread, $i); |
9850bf21 RH |
81 | print "# parent $$: continue\n"; |
82 | push(@kids, $t); | |
83 | } | |
84 | for my $t (@kids) { | |
85 | print "# parent $$: waiting for join\n"; | |
86 | $t->join(); | |
87 | print "# parent $$: thread exited\n"; | |
88 | } | |
89 | } | |
90 | ||
91 | do_sort_threads(2); # crashes | |
92 | ok(1); | |
cfae286e NC |
93 | |
94 | # Change 24643 made the mistake of assuming that CvCONST can only be true on | |
95 | # XSUBs. Somehow it can also end up on perl subs. | |
96 | fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs'); | |
97 | use constant x=>1; | |
98 | use threads; | |
99 | $SIG{__WARN__} = sub{}; | |
100 | async sub {}; | |
101 | print "ok"; | |
102 | EOI | |
db4997f0 NC |
103 | |
104 | # From a test case by Tim Bunce in | |
105 | # http://www.nntp.perl.org/group/perl.perl5.porters/63123 | |
106 | fresh_perl_is(<<'EOI', 'ok', { }, 'Ensure PL_linestr can be cloned'); | |
107 | use threads; | |
e81465be | 108 | print do 'op/threads_create.pl' || die $@; |
db4997f0 | 109 | EOI |
9708a845 | 110 | |
9708a845 JH |
111 | |
112 | # Scalars leaked: 1 | |
113 | foreach my $BLOCK (qw(CHECK INIT)) { | |
114 | fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block"); | |
115 | use threads; | |
116 | $BLOCK { threads->create(sub {})->join; } | |
117 | print 'ok'; | |
118 | EOI | |
119 | } | |
120 | ||
121 | # Scalars leaked: 1 | |
122 | fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138'); | |
123 | use threads; | |
124 | leak($x); | |
125 | sub leak | |
126 | { | |
127 | local $x; | |
128 | threads->create(sub {})->join(); | |
129 | } | |
130 | print 'ok'; | |
131 | EOI | |
132 | ||
9708a845 | 133 | |
f0d3b40c JH |
134 | # [perl #45053] Memory corruption with heavy module loading in threads |
135 | # | |
136 | # run-time usage of newCONSTSUB (as done by the IO boot code) wasn't | |
137 | # thread-safe - got occasional coredumps or malloc corruption | |
83d6f158 | 138 | watchdog(180, "process"); |
f0d3b40c | 139 | { |
76eabe0a | 140 | local $SIG{__WARN__} = sub {}; # Ignore any thread creation failure warnings |
f0d3b40c | 141 | my @t; |
76eabe0a JH |
142 | for (1..100) { |
143 | my $thr = threads->create( sub { require IO }); | |
144 | last if !defined($thr); # Probably ran out of memory | |
145 | push(@t, $thr); | |
146 | } | |
f0d3b40c JH |
147 | $_->join for @t; |
148 | ok(1, '[perl #45053]'); | |
149 | } | |
150 | ||
f708cfc1 NC |
151 | sub matchit { |
152 | is (ref $_[1], "Regexp"); | |
153 | like ($_[0], $_[1]); | |
154 | } | |
155 | ||
156 | threads->new(\&matchit, "Pie", qr/pie/i)->join(); | |
157 | ||
158 | # tests in threads don't get counted, so | |
159 | curr_test(curr_test() + 2); | |
160 | ||
1db36481 DM |
161 | |
162 | # the seen_evals field of a regexp was getting zeroed on clone, so | |
93f09d7b | 163 | # within a thread it didn't know that a regex object contained a 'safe' |
d24ca0c5 | 164 | # code expression, so it later died with 'Eval-group not allowed' when |
1db36481 DM |
165 | # you tried to interpolate the object |
166 | ||
167 | sub safe_re { | |
168 | my $re = qr/(?{1})/; # this is literal, so safe | |
169 | eval { "a" =~ /$re$re/ }; # interpolating safe values, so safe | |
170 | ok($@ eq "", 'clone seen-evals'); | |
171 | } | |
172 | threads->new(\&safe_re)->join(); | |
173 | ||
174 | # tests in threads don't get counted, so | |
175 | curr_test(curr_test() + 1); | |
176 | ||
1dffc4d1 NC |
177 | # This used to crash in 5.10.0 [perl #64954] |
178 | ||
179 | undef *a; | |
180 | threads->new(sub {})->join; | |
181 | pass("undefing a typeglob doesn't cause a crash during cloning"); | |
1db36481 | 182 | |
7c76c2a0 | 183 | |
7c76c2a0 JH |
184 | # Test we don't get: |
185 | # panic: del_backref during global destruction. | |
27bca322 FC |
186 | # when returning a non-closure sub from a thread and subsequently starting |
187 | # a new thread. | |
188 | fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic [perl #70748]'); | |
7c76c2a0 JH |
189 | use threads; |
190 | sub foo { return (sub { }); } | |
191 | my $bar = threads->create(\&foo)->join(); | |
192 | threads->create(sub { })->join(); | |
193 | print "ok"; | |
194 | EOI | |
195 | ||
27bca322 | 196 | # Another, more reliable test for the same del_backref bug: |
e4295668 NC |
197 | fresh_perl_is( |
198 | <<' EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)' | |
27bca322 FC |
199 | use threads; |
200 | push @bar, threads->create(sub{sub{}})->join() for 1...10; | |
201 | print "ok"; | |
202 | EOJ | |
203 | ); | |
204 | ||
205 | # Simple closure-returning test: At least this case works (though it | |
206 | # leaks), and we don't want to break it. | |
e4295668 | 207 | fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure'); |
27bca322 FC |
208 | use threads; |
209 | print create threads sub { | |
e4295668 | 210 | my $x = 'foo'; |
27bca322 FC |
211 | sub{sub{$x}} |
212 | }=>->join->()() | |
213 | //"undef" | |
214 | EOJ | |
7c76c2a0 | 215 | |
3287f6c3 NC |
216 | # At the point of thread creation, $h{1} is on the temps stack. |
217 | # The weak reference $a, however, is visible from the symbol table. | |
218 | fresh_perl_is(<<'EOI', 'ok', { }, 'Test for 34394ecd06e704e9'); | |
219 | use threads; | |
220 | %h = (1, 2); | |
221 | use Scalar::Util 'weaken'; | |
222 | $a = \$h{1}; | |
223 | weaken($a); | |
224 | delete $h{1} && threads->create(sub {}, shift)->join(); | |
225 | print 'ok'; | |
226 | EOI | |
227 | ||
f7abe70b NC |
228 | # This will fail in "interesting" ways if stashes in clone_params is not |
229 | # initialised correctly. | |
230 | fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE reference/, { }, 'RT #73046'); | |
231 | use strict; | |
232 | use threads; | |
233 | ||
234 | sub foo::bar; | |
235 | ||
236 | my %h = (1, *{$::{'foo::'}}{HASH}); | |
237 | *{$::{'foo::'}} = {}; | |
238 | ||
239 | threads->create({}, delete $h{1})->join(); | |
240 | ||
241 | print "end"; | |
242 | EOI | |
243 | ||
d08d57ef NC |
244 | fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_'); |
245 | use threads; | |
246 | my %h = (1, []); | |
247 | use Scalar::Util 'weaken'; | |
248 | my $a = $h{1}; | |
249 | weaken($a); | |
250 | delete $h{1} && threads->create(sub {}, shift)->join(); | |
251 | print 'ok'; | |
252 | EOI | |
253 | ||
05d04d9c NC |
254 | { |
255 | my $got; | |
256 | sub stuff { | |
257 | my $a; | |
258 | if (@_) { | |
259 | $a = "Leakage"; | |
260 | threads->create(\&stuff)->join(); | |
261 | } else { | |
262 | is ($a, undef, 'RT #73086 - clone used to clone active pads'); | |
263 | } | |
264 | } | |
265 | ||
266 | stuff(1); | |
267 | ||
268 | curr_test(curr_test() + 1); | |
269 | } | |
270 | ||
adf8f095 NC |
271 | { |
272 | my $got; | |
273 | sub more_stuff { | |
274 | my $a; | |
275 | $::b = \$a; | |
276 | if (@_) { | |
277 | $a = "More leakage"; | |
278 | threads->create(\&more_stuff)->join(); | |
279 | } else { | |
280 | is ($a, undef, 'Just special casing lexicals in ?{ ... }'); | |
281 | } | |
282 | } | |
283 | ||
284 | more_stuff(1); | |
285 | ||
286 | curr_test(curr_test() + 1); | |
287 | } | |
288 | ||
04518cc3 NC |
289 | # Test from Jerry Hedden, reduced by him from Object::InsideOut's tests. |
290 | fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt during CLONE'); | |
291 | use strict; | |
292 | use warnings; | |
293 | ||
294 | use threads; | |
295 | ||
296 | { | |
297 | package My::Obj; | |
298 | use Scalar::Util 'weaken'; | |
299 | ||
300 | my %reg; | |
301 | ||
302 | sub new | |
303 | { | |
304 | # Create object with ID = 1 | |
305 | my $class = shift; | |
306 | my $id = 1; | |
307 | my $obj = bless(\do{ my $scalar = $id; }, $class); | |
308 | ||
309 | # Save weak copy of object for reference during cloning | |
310 | weaken($reg{$id} = $obj); | |
311 | ||
312 | # Return object | |
313 | return $obj; | |
314 | } | |
315 | ||
316 | # Return the internal ID of the object | |
317 | sub id | |
318 | { | |
319 | my $obj = shift; | |
320 | return $$obj; | |
321 | } | |
322 | ||
323 | # During cloning 'look' at the object | |
324 | sub CLONE { | |
325 | foreach my $id (keys(%reg)) { | |
326 | # This triggers SvREFCNT_inc() then SvREFCNT_dec() on the referant. | |
327 | my $obj = $reg{$id}; | |
328 | } | |
329 | } | |
330 | } | |
331 | ||
332 | # Create object in 'main' thread | |
333 | my $obj = My::Obj->new(); | |
334 | my $id = $obj->id(); | |
335 | die "\$id is '$id'" unless $id == 1; | |
336 | ||
337 | # Access object in thread | |
338 | threads->create( | |
339 | sub { | |
340 | print $obj->id() == 1 ? "ok\n" : "not ok '" . $obj->id() . "'\n"; | |
341 | } | |
342 | )->join(); | |
343 | ||
344 | EOI | |
345 | ||
3c78429c DM |
346 | # make sure peephole optimiser doesn't recurse heavily. |
347 | # (We run this inside a thread to get a small stack) | |
348 | ||
349 | { | |
350 | # lots of constructs that have o->op_other etc | |
351 | my $code = <<'EOF'; | |
352 | $r = $x || $y; | |
353 | $x ||= $y; | |
354 | $r = $x // $y; | |
355 | $x //= $y; | |
356 | $r = $x && $y; | |
357 | $x &&= $y; | |
358 | $r = $x ? $y : $z; | |
3c78429c DM |
359 | @a = map $x+1, @a; |
360 | @a = grep $x+1, @a; | |
361 | $r = /$x/../$y/; | |
18e84e81 DM |
362 | |
363 | # this one will fail since we removed tail recursion optimisation | |
364 | # with f11ca51e41e8 | |
365 | #while (1) { $x = 0 }; | |
366 | ||
3c78429c DM |
367 | while (0) { $x = 0 }; |
368 | for ($x=0; $y; $z=0) { $r = 0 }; | |
369 | for (1) { $x = 0 }; | |
370 | { $x = 0 }; | |
371 | $x =~ s/a/$x + 1/e; | |
372 | EOF | |
2ff884af | 373 | $code = 'my ($r, $x,$y,$z,@a); return 5; ' . ($code x 1000); |
3c78429c DM |
374 | my $res = threads->create(sub { eval $code})->join; |
375 | is($res, 5, "avoid peephole recursion"); | |
376 | } | |
377 | ||
378 | ||
2e0cfa16 | 379 | # [perl #78494] Pipes shared between threads block when closed |
2e0cfa16 FC |
380 | { |
381 | my $perl = which_perl; | |
382 | $perl = qq'"$perl"' if $perl =~ /\s/; | |
383 | open(my $OUT, "|$perl") || die("ERROR: $!"); | |
384 | threads->create(sub { })->join; | |
385 | ok(1, "Pipes shared between threads do not block when closed"); | |
386 | } | |
387 | ||
6eea2b42 FC |
388 | # [perl #105208] Typeglob clones should not be cloned again during a join |
389 | { | |
390 | threads->create(sub { sub { $::hypogamma = 3 } })->join->(); | |
391 | is $::hypogamma, 3, 'globs cloned and joined are not recloned'; | |
392 | } | |
393 | ||
f03015cd FC |
394 | fresh_perl_is( |
395 | 'use threads;' . | |
396 | 'async { delete $::{INC}; eval q"my $foo : bar" } ->join; print "ok\n";', | |
397 | "ok", | |
398 | {}, | |
399 | 'no crash when deleting $::{INC} in thread' | |
400 | ); | |
401 | ||
9708a845 | 402 | # EOF |