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