t/op/threads.t

   1 #!perl
   2
   3 BEGIN {
   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(23);
  20 }
  21
  22 use strict;
  23 use warnings;
  24 use threads;
  25
  26 # test that we don't get:
  27 # Attempt to free unreferenced scalar: SV 0x40173f3c
  28 fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads');
  29 use threads;
  30 threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
  31 print "ok";
  32 EOI
  33
  34 #PR24660
  35 # test that we don't get:
  36 # Attempt to free unreferenced scalar: SV 0x814e0dc.
  37 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads');
  38 use threads;
  39 use Scalar::Util;
  40 my $data = "a";
  41 my $obj = \$data;
  42 my $copy = $obj;
  43 Scalar::Util::weaken($copy);
  44 threads->create(sub { 1 })->join for (1..1);
  45 print "ok";
  46 EOI
  47
  48 #PR24663
  49 # test that we don't get:
  50 # panic: magic_killbackrefs.
  51 # Scalars leaked: 3
  52 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads');
  53 package Foo;
  54 sub new { bless {},shift }
  55 package main;
  56 use threads;
  57 use Scalar::Util qw(weaken);
  58 my $object = Foo->new;
  59 my $ref = $object;
  60 weaken $ref;
  61 threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems
  62 print "ok";
  63 EOI
  64
  65 #PR30333 - sort() crash with threads
  66 sub mycmp { length($b) <=> length($a) }
  67
  68 sub 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
  83 sub 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
  98 do_sort_threads(2);        # crashes
  99 ok(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.
 103 fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs');
 104 use constant x=>1;
 105 use threads;
 106 $SIG{__WARN__} = sub{};
 107 async sub {};
 108 print "ok";
 109 EOI
 110
 111 # From a test case by Tim Bunce in
 112 # http://www.nntp.perl.org/group/perl.perl5.porters/63123
 113 fresh_perl_is(<<'EOI', 'ok', { }, 'Ensure PL_linestr can be cloned');
 114 use threads;
 115 print do 'op/threads_create.pl' || die $@;
 116 EOI
 117
 118
 119 # Scalars leaked: 1
 120 foreach 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';
 125 EOI
 126 }
 127
 128 # Scalars leaked: 1
 129 fresh_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';
 138 EOI
 139
 140
 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 {
 146     local $SIG{__WARN__} = sub {};   # Ignore any thread creation failure warnings
 147     my @t;
 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     }
 153     $_->join for @t;
 154     ok(1, '[perl #45053]');
 155 }
 156
 157 sub matchit {
 158     is (ref $_[1], "Regexp");
 159     like ($_[0], $_[1]);
 160 }
 161
 162 threads->new(\&matchit, "Pie", qr/pie/i)->join();
 163
 164 # tests in threads don't get counted, so
 165 curr_test(curr_test() + 2);
 166
 167
 168 # the seen_evals field of a regexp was getting zeroed on clone, so
 169 # within a thread it didn't  know that a regex object contrained a 'safe'
 170 # re_eval expression, so it later died with 'Eval-group not allowed' when
 171 # you tried to interpolate the object
 172
 173 sub 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 }
 178 threads->new(\&safe_re)->join();
 179
 180 # tests in threads don't get counted, so
 181 curr_test(curr_test() + 1);
 182
 183 # This used to crash in 5.10.0 [perl #64954]
 184
 185 undef *a;
 186 threads->new(sub {})->join;
 187 pass("undefing a typeglob doesn't cause a crash during cloning");
 188
 189
 190 # Test we don't get:
 191 # panic: del_backref during global destruction.
 192 # when returning a non-closure sub from a thread and subsequently starting
 193 # a new thread.
 194 fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic [perl #70748]');
 195 use threads;
 196 sub foo { return (sub { }); }
 197 my $bar = threads->create(\&foo)->join();
 198 threads->create(sub { })->join();
 199 print "ok";
 200 EOI
 201
 202 # Another, more reliable test for the same del_backref bug:
 203 fresh_perl_is(
 204  <<'   EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)'
 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.
 213 fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure');
 214 use threads;
 215 print create threads sub {
 216  my $x = 'foo';
 217  sub{sub{$x}}
 218 }=>->join->()()
 219  //"undef"
 220 EOJ
 221
 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.
 224 fresh_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';
 232 EOI
 233
 234 # This will fail in "interesting" ways if stashes in clone_params is not
 235 # initialised correctly.
 236 fresh_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";
 248 EOI
 249
 250 fresh_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';
 258 EOI
 259
 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
 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
 295 # Test from Jerry Hedden, reduced by him from Object::InsideOut's tests.
 296 fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt during CLONE');
 297 use strict;
 298 use warnings;
 299
 300 use 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
 339 my $obj = My::Obj->new();
 340 my $id = $obj->id();
 341 die "\$id is '$id'" unless $id == 1;
 342
 343 # Access object in thread
 344 threads->create(
 345     sub {
 346         print $obj->id() == 1 ? "ok\n" : "not ok '" . $obj->id() . "'\n";
 347     }
 348 )->join();
 349
 350 EOI
 351
 352 # EOF