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 }
   7
   8 use strict;
   9 use Config;
  10
  11 BEGIN {
  12      if (!$Config{useithreads}) {
  13         print "1..0 # Skip: no ithreads\n";
  14         exit 0;
  15      }
  16      if ($ENV{PERL_CORE_MINITEST}) {
  17        print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
  18        exit 0;
  19      }
  20      plan(4);
  21 }
  22 use threads;
  23
  24 # test that we don't get:
  25 # Attempt to free unreferenced scalar: SV 0x40173f3c
  26 fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads');
  27 use threads;
  28 threads->new(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
  29 print "ok";
  30 EOI
  31
  32 #PR24660
  33 # test that we don't get:
  34 # Attempt to free unreferenced scalar: SV 0x814e0dc.
  35 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads');
  36 use threads;
  37 use Scalar::Util;
  38 my $data = "a";
  39 my $obj = \$data;
  40 my $copy = $obj;
  41 Scalar::Util::weaken($copy);
  42 threads->new(sub { 1 })->join for (1..1);
  43 print "ok";
  44 EOI
  45
  46 #PR24663
  47 # test that we don't get:
  48 # panic: magic_killbackrefs.
  49 # Scalars leaked: 3
  50 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads');
  51 package Foo;
  52 sub new { bless {},shift }
  53 package main;
  54 use threads;
  55 use Scalar::Util qw(weaken);
  56 my $object = Foo->new;
  57 my $ref = $object;
  58 weaken $ref;
  59 threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems
  60 print "ok";
  61 EOI
  62
  63 #PR30333 - sort() crash with threads
  64 sub mycmp { length($b) <=> length($a) }
  65
  66 sub do_sort_one_thread {
  67    my $kid = shift;
  68    print "# kid $kid before sort\n";
  69    my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
  70                 'hello', 's', 'thisisalongname', '1', '2', '3',
  71                 'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
  72
  73    for my $j (1..99999) {
  74       for my $k (sort mycmp @list) {}
  75    }
  76    print "# kid $kid after sort, sleeping 1\n";
  77    sleep(1);
  78    print "# kid $kid exit\n";
  79 }
  80
  81 sub do_sort_threads {
  82    my $nthreads = shift;
  83    my @kids = ();
  84    for my $i (1..$nthreads) {
  85       my $t = threads->new(\&do_sort_one_thread, $i);
  86       print "# parent $$: continue\n";
  87       push(@kids, $t);
  88    }
  89    for my $t (@kids) {
  90       print "# parent $$: waiting for join\n";
  91       $t->join();
  92       print "# parent $$: thread exited\n";
  93    }
  94 }
  95
  96 do_sort_threads(2);        # crashes
  97 ok(1);