| 1 | #!perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | require './test.pl'; |
| 7 | $| = 1; |
| 8 | |
| 9 | skip_all_without_config('useithreads'); |
| 10 | skip_all_if_miniperl("no dynamic loading on miniperl, no threads"); |
| 11 | |
| 12 | plan(27); |
| 13 | } |
| 14 | |
| 15 | use strict; |
| 16 | use warnings; |
| 17 | use threads; |
| 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; |
| 23 | threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2; |
| 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); |
| 37 | threads->create(sub { 1 })->join for (1..1); |
| 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; |
| 54 | threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems |
| 55 | print "ok"; |
| 56 | EOI |
| 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) { |
| 80 | my $t = threads->create(\&do_sort_one_thread, $i); |
| 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); |
| 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 |
| 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; |
| 108 | print do 'op/threads_create.pl' || die $@; |
| 109 | EOI |
| 110 | |
| 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 | |
| 133 | |
| 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 |
| 138 | watchdog(180, "process"); |
| 139 | { |
| 140 | local $SIG{__WARN__} = sub {}; # Ignore any thread creation failure warnings |
| 141 | my @t; |
| 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 | } |
| 147 | $_->join for @t; |
| 148 | ok(1, '[perl #45053]'); |
| 149 | } |
| 150 | |
| 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 | |
| 161 | |
| 162 | # the seen_evals field of a regexp was getting zeroed on clone, so |
| 163 | # within a thread it didn't know that a regex object contained a 'safe' |
| 164 | # code expression, so it later died with 'Eval-group not allowed' when |
| 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 | |
| 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"); |
| 182 | |
| 183 | |
| 184 | # Test we don't get: |
| 185 | # panic: del_backref during global destruction. |
| 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]'); |
| 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 | |
| 196 | # Another, more reliable test for the same del_backref bug: |
| 197 | fresh_perl_is( |
| 198 | <<' EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)' |
| 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. |
| 207 | fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure'); |
| 208 | use threads; |
| 209 | print create threads sub { |
| 210 | my $x = 'foo'; |
| 211 | sub{sub{$x}} |
| 212 | }=>->join->()() |
| 213 | //"undef" |
| 214 | EOJ |
| 215 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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; |
| 359 | @a = map $x+1, @a; |
| 360 | @a = grep $x+1, @a; |
| 361 | $r = /$x/../$y/; |
| 362 | |
| 363 | # this one will fail since we removed tail recursion optimisation |
| 364 | # with f11ca51e41e8 |
| 365 | #while (1) { $x = 0 }; |
| 366 | |
| 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 |
| 373 | $code = 'my ($r, $x,$y,$z,@a); return 5; ' . ($code x 1000); |
| 374 | my $res = threads->create(sub { eval $code})->join; |
| 375 | is($res, 5, "avoid peephole recursion"); |
| 376 | } |
| 377 | |
| 378 | |
| 379 | # [perl #78494] Pipes shared between threads block when closed |
| 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 | |
| 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 | |
| 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 | |
| 402 | # EOF |