t/40-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_VARIABLE_MAGIC_TEST_THREADS} ? 1 : !1;
  16  my $t_v   = $force ? '0' : '1.67';
  17  my $ts_v  = $force ? '0' : '1.14';
  18  skipall 'This perl wasn\'t built to support threads'
  19                                                     unless $Config{useithreads};
  20  skipall 'perl 5.13.4 required to test thread safety'
  21                                               unless $force or "$]" >= 5.013004;
  22  skipall "threads $t_v required to test thread safety"
  23                                               unless eval "use threads $t_v; 1";
  24  skipall "threads::shared $ts_v required to test thread safety"
  25                                      unless eval "use threads::shared $ts_v; 1";
  26 }
  27
  28 use Test::More; # after threads
  29
  30 use Variable::Magic qw<
  31  wizard cast dispell getdata
  32  VMG_THREADSAFE VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT
  33 >;
  34
  35 BEGIN {
  36  skipall 'This Variable::Magic isn\'t thread safe' unless VMG_THREADSAFE;
  37  plan tests => (4 * 18 + 1) + (4 * 13 + 1);
  38  defined and diag "Using threads $_"         for $threads::VERSION;
  39  defined and diag "Using threads::shared $_" for $threads::shared::VERSION;
  40 }
  41
  42 my $destroyed : shared = 0;
  43
  44 sub try {
  45  my ($dispell, $op_info) = @_;
  46  my $tid = threads->tid();
  47  my $c   = 0;
  48  my $wiz = eval {
  49   wizard data    => sub { $_[1] + $tid },
  50          get     => sub { ++$c; 0 },
  51          set     => sub {
  52                      my $op = $_[-1];
  53                      if ($op_info == VMG_OP_INFO_OBJECT) {
  54                       is_deeply { class => ref($op),   name => $op->name },
  55                                 { class => 'B::BINOP', name => 'sassign' },
  56                                 "op object in thread $tid is correct";
  57                      } else {
  58                       is $op, 'sassign', "op name in thread $tid is correct";
  59                      }
  60                      0
  61                     },
  62          free    => sub { lock $destroyed; ++$destroyed; 0 },
  63          op_info => $op_info
  64  };
  65  is($@,     '',    "wizard in thread $tid doesn't croak");
  66  isnt($wiz, undef, "wizard in thread $tid is defined");
  67  is($c,     0,     "wizard in thread $tid doesn't trigger magic");
  68  my $a = 3;
  69  my $res = eval { cast $a, $wiz, sub { 5 }->() };
  70  is($@, '', "cast in thread $tid doesn't croak");
  71  is($c, 0,  "cast in thread $tid doesn't trigger magic");
  72  my $b;
  73  eval { $b = $a };
  74  is($@, '', "get in thread $tid doesn't croak");
  75  is($b, 3,  "get in thread $tid returns the right thing");
  76  is($c, 1,  "get in thread $tid triggers magic");
  77  my $d = eval { getdata $a, $wiz };
  78  is($@, '',       "getdata in thread $tid doesn't croak");
  79  is($d, 5 + $tid, "getdata in thread $tid returns the right thing");
  80  is($c, 1,        "getdata in thread $tid doesn't trigger magic");
  81  eval { $a = 9 };
  82  is($@, '', "set in thread $tid (check opname) doesn't croak");
  83  if ($dispell) {
  84   $res = eval { dispell $a, $wiz };
  85   is($@, '', "dispell in thread $tid doesn't croak");
  86   is($c, 1,  "dispell in thread $tid doesn't trigger magic");
  87   undef $b;
  88   eval { $b = $a };
  89   is($@, '', "get in thread $tid after dispell doesn't croak");
  90   is($b, 9,  "get in thread $tid after dispell returns the right thing");
  91   is($c, 1,  "get in thread $tid after dispell doesn't trigger magic");
  92  }
  93  return; # Ugly if not here
  94 }
  95
  96 for my $dispell (1, 0) {
  97  {
  98   lock $destroyed;
  99   $destroyed = 0;
 100  }
 101
 102  my @t = map { threads->create(\&try, $dispell, $_) }
 103                               (VMG_OP_INFO_NAME) x 2, (VMG_OP_INFO_OBJECT) x 2;
 104  $_->join for @t;
 105
 106  {
 107   lock $destroyed;
 108   is $destroyed, (1 - $dispell) * 4, 'destructors';
 109  }
 110 }