t/40-threads.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Config qw/%Config/;
   7
   8 BEGIN {
   9  if (!$Config{useithreads}) {
  10   require Test::More;
  11   Test::More->import;
  12   plan(skip_all => 'This perl wasn\'t built to support threads');
  13  }
  14 }
  15
  16 use threads;
  17
  18 use Test::More;
  19
  20 BEGIN {
  21  require indirect;
  22  if (indirect::I_THREADSAFE()) {
  23   plan tests => 10 * 2 * (2 + 3);
  24   defined and diag "Using threads $_" for $threads::VERSION;
  25  } else {
  26   plan skip_all => 'This indirect isn\'t thread safe';
  27  }
  28 }
  29
  30 sub expect {
  31  my ($pkg) = @_;
  32  qr/^Indirect call of method "new" on object "$pkg" at \(eval \d+\) line \d+/;
  33 }
  34
  35 {
  36  no indirect;
  37
  38  sub try {
  39   my $tid = threads->tid();
  40
  41   for (1 .. 2) {
  42    {
  43     my $class = "Coconut$tid";
  44     my @warns;
  45     {
  46      local $SIG{__WARN__} = sub { push @warns, @_ };
  47      eval 'die "the code compiled but it shouldn\'t have\n";
  48            no indirect ":fatal"; my $x = new ' . $class . ' 1, 2;';
  49     }
  50     like         $@ || '', expect($class),
  51                       "\"no indirect\" in eval in thread $tid died as expected";
  52     is_deeply \@warns, [ ],
  53                       "\"no indirect\" in eval in thread $tid didn't warn";
  54    }
  55
  56 SKIP:
  57    {
  58     skip 'Hints aren\'t propagated into eval STRING below perl 5.10' => 3
  59                                                              unless $] >= 5.010;
  60     my $class = "Pineapple$tid";
  61     my @warns;
  62     {
  63      local $SIG{__WARN__} = sub { push @warns, @_ };
  64      eval 'return; my $y = new ' . $class . ' 1, 2;';
  65     }
  66     is $@, '',
  67              "\"no indirect\" propagated into eval in thread $tid didn't croak";
  68     my $first = shift @warns;
  69     like $first || '', expect($class),
  70               "\"no indirect\" propagated into eval in thread $tid warned once";
  71     is_deeply \@warns, [ ],
  72          "\"no indirect\" propagated into eval in thread $tid warned just once";
  73    }
  74   }
  75  }
  76 }
  77
  78 my @t = map threads->create(\&try), 1 .. 10;
  79 $_->join for @t;