t/op/threads.t

   1 #!./perl
   2 BEGIN {
   3      chdir 't' if -d 't';
   4      @INC = '../lib';
   5      require './test.pl';       # for which_perl() etc
   6      $| = 1;
   7 }
   8
   9 use strict;
  10 use Config;
  11
  12 BEGIN {
  13      if (!$Config{useithreads}) {
  14         print "1..0 # Skip: no ithreads\n";
  15         exit 0;
  16      }
  17      if ($ENV{PERL_CORE_MINITEST}) {
  18        print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
  19        exit 0;
  20      }
  21      plan(5);
  22 }
  23 use threads;
  24
  25 # test that we don't get:
  26 # Attempt to free unreferenced scalar: SV 0x40173f3c
  27 fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads');
  28 use threads;
  29 threads->new(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
  30 print "ok";
  31 EOI
  32
  33 #PR24660
  34 # test that we don't get:
  35 # Attempt to free unreferenced scalar: SV 0x814e0dc.
  36 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads');
  37 use threads;
  38 use Scalar::Util;
  39 my $data = "a";
  40 my $obj = \$data;
  41 my $copy = $obj;
  42 Scalar::Util::weaken($copy);
  43 threads->new(sub { 1 })->join for (1..1);
  44 print "ok";
  45 EOI
  46
  47 #PR24663
  48 # test that we don't get:
  49 # panic: magic_killbackrefs.
  50 # Scalars leaked: 3
  51 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads');
  52 package Foo;
  53 sub new { bless {},shift }
  54 package main;
  55 use threads;
  56 use Scalar::Util qw(weaken);
  57 my $object = Foo->new;
  58 my $ref = $object;
  59 weaken $ref;
  60 threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems
  61 print "ok";
  62 EOI
  63
  64 #PR30333 - sort() crash with threads
  65 sub mycmp { length($b) <=> length($a) }
  66
  67 sub 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
  82 sub do_sort_threads {
  83    my $nthreads = shift;
  84    my @kids = ();
  85    for my $i (1..$nthreads) {
  86       my $t = threads->new(\&do_sort_one_thread, $i);
  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
  97 do_sort_threads(2);        # crashes
  98 ok(1);
  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.
 102 fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs');
 103 use constant x=>1;
 104 use threads;
 105 $SIG{__WARN__} = sub{};
 106 async sub {};
 107 print "ok";
 108 EOI