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  return qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"\s+at\s+\(eval\s+\d+\)\s+line\s+\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 'die "ok\n"; my $y = new ' . $class . ' 1, 2;';
  65     }
  66     is             $@, "ok\n",
  67     my $first = shift @warns;
  68     like $first || '', expect($class),
  69               "\"no indirect\" propagated into eval in thread $tid warned once";
  70     is_deeply \@warns, [ ],
  71          "\"no indirect\" propagated into eval in thread $tid warned just once";
  72    }
  73   }
  74  }
  75 }
  76
  77 my @t = map threads->create(\&try), 1 .. 10;
  78 $_->join for @t;