t/30-threads.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 sub skipall {
   7  my ($msg) = @_;
   8  require Test::More;
   9  Test::More::plan(skip_all => $msg);
  10 }
  11
  12 use Config qw/%Config/;
  13
  14 BEGIN {
  15  my $force = $ENV{PERL_LEXICAL_TYPES_TEST_THREADS} ? 1 : !1;
  16  skipall 'This perl wasn\'t built to support threads'
  17                                                     unless $Config{useithreads};
  18  skipall 'perl 5.13.4 required to test thread safety'
  19                                                 unless $force or $] >= 5.013004;
  20 }
  21
  22 use threads;
  23
  24 use Test::More;
  25
  26 BEGIN {
  27  require Lexical::Types;
  28  skipall 'This Lexical::Types isn\'t thread safe'
  29                                          unless Lexical::Types::LT_THREADSAFE();
  30  plan tests => 10 * 2 * 3 * (1 + 2);
  31  defined and diag "Using threads $_" for $threads::VERSION;
  32 }
  33
  34 {
  35  package Lexical::Types::Test::Tag;
  36
  37  sub TYPEDSCALAR {
  38   my $tid = threads->tid();
  39   my ($file, $line) = (caller(0))[1, 2];
  40   my $where = "at $file line $line in thread $tid";
  41   local $Test::Builder::Level = $Test::Builder::Level + 1;
  42   Test::More::is($_[0], __PACKAGE__, "base type is correct $where");
  43   Test::More::is($_[2], 'Tag', "original type is correct $where");
  44   $_[1] = $tid;
  45   ();
  46  }
  47 }
  48
  49 { package Tag; }
  50
  51 use Lexical::Types as => 'Lexical::Types::Test::';
  52
  53 sub try {
  54  my $tid = threads->tid();
  55
  56  for (1 .. 2) {
  57   my Tag $t;
  58   is $t, $tid, "typed lexical correctly initialized at run $_ in thread $tid";
  59
  60   eval <<'EVALD';
  61    use Lexical::Types as => "Lexical::Types::Test::";
  62    my Tag $t2;
  63    is $t2, $tid, "typed lexical correctly initialized in eval at run $_ in thread $tid";
  64 EVALD
  65   diag $@ if $@;
  66
  67 SKIP:
  68   {
  69    skip 'Hints aren\'t propagated into eval STRING below perl 5.10' => 3
  70                                                              unless $] >= 5.010;
  71    eval <<'EVALD';
  72     my Tag $t3;
  73     is $t3, $tid, "typed lexical correctly initialized in eval (propagated) at run $_ in thread $tid"
  74 EVALD
  75   }
  76  }
  77 }
  78
  79 my @t = map threads->create(\&try), 1 .. 10;
  80 $_->join for @t;