t/40-threads.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use lib 't/lib';
   7 use indirect::TestThreads;
   8
   9 use Test::Leaner;
  10
  11 sub expect {
  12  my ($pkg) = @_;
  13  qr/^Indirect call of method "new" on object "$pkg" at \(eval \d+\) line \d+/;
  14 }
  15
  16 {
  17  no indirect;
  18
  19  sub try {
  20   my $tid = threads->tid();
  21
  22   for (1 .. 2) {
  23    {
  24     my $class = "Coconut$tid";
  25     my @warns;
  26     {
  27      local $SIG{__WARN__} = sub { push @warns, @_ };
  28      eval 'die "the code compiled but it shouldn\'t have\n";
  29            no indirect ":fatal"; my $x = new ' . $class . ' 1, 2;';
  30     }
  31     like         $@ || '', expect($class),
  32                       "\"no indirect\" in eval in thread $tid died as expected";
  33     is_deeply \@warns, [ ],
  34                       "\"no indirect\" in eval in thread $tid didn't warn";
  35    }
  36
  37 SKIP:
  38    {
  39     skip 'Hints aren\'t propagated into eval STRING below perl 5.10' => 3
  40                                                            unless "$]" >= 5.010;
  41     my $class = "Pineapple$tid";
  42     my @warns;
  43     {
  44      local $SIG{__WARN__} = sub { push @warns, @_ };
  45      eval 'return; my $y = new ' . $class . ' 1, 2;';
  46     }
  47     is $@, '',
  48              "\"no indirect\" propagated into eval in thread $tid didn't croak";
  49     my $first = shift @warns;
  50     like $first || '', expect($class),
  51               "\"no indirect\" propagated into eval in thread $tid warned once";
  52     is_deeply \@warns, [ ],
  53          "\"no indirect\" propagated into eval in thread $tid warned just once";
  54    }
  55   }
  56  }
  57 }
  58
  59 my @threads = map spawn(\&try), 1 .. 10;
  60
  61 $_->join for @threads;
  62
  63 pass 'done';
  64
  65 done_testing(scalar(@threads) * 2 * (2 + 3) + 1);