t/40-threads.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use lib 't/lib';
   7 use VPIT::TestHelpers (
   8  threads => [ 'Variable::Magic' => 'Variable::Magic::VMG_THREADSAFE()' ],
   9 );
  10
  11 use Test::Leaner 'no_plan';
  12
  13 my $destroyed : shared = 0;
  14
  15 sub try {
  16  my ($dispell, $op_info) = @_;
  17  my $tid = threads->tid;
  18
  19  my $c = 0;
  20  my $wiz;
  21
  22  {
  23   local $@;
  24   eval { require Variable::Magic; 1 } or return;
  25  }
  26
  27  {
  28   local $@;
  29   $wiz = eval {
  30    Variable::Magic::wizard(
  31     data    => sub { $_[1] + $tid },
  32     get     => sub { ++$c; 0 },
  33     set     => sub {
  34      my $op = $_[-1];
  35
  36      my $assign_op    = ("$]" < 5.037_003) ? 'sassign': 'padsv_store';
  37      my $assign_op_cl = ("$]" < 5.037_003) ? 'B::BINOP': 'B::UNOP';
  38
  39      if ($op_info eq 'object') {
  40       is_deeply { class => ref($op),   name => $op->name },
  41                 { class => $assign_op_cl, name => $assign_op },
  42                 "op object in thread $tid is correct";
  43      } else {
  44       is $op, $assign_op, "op name in thread $tid is correct";
  45      }
  46
  47      return 0;
  48     },
  49     free    => sub { lock $destroyed; ++$destroyed; 0 },
  50     op_info => $op_info eq 'object' ? Variable::Magic::VMG_OP_INFO_OBJECT()
  51                                     : Variable::Magic::VMG_OP_INFO_NAME()
  52    );
  53   };
  54   is $@,     '',    "wizard in thread $tid doesn't croak";
  55   isnt $wiz, undef, "wizard in thread $tid is defined";
  56   is $c,     0,     "wizard in thread $tid doesn't trigger magic";
  57  }
  58
  59  my $a = 3;
  60
  61  {
  62   local $@;
  63   my $res = eval { &Variable::Magic::cast(\$a, $wiz, sub { 5 }->()) };
  64   is $@, '', "cast in thread $tid doesn't croak";
  65   is $c, 0,  "cast in thread $tid doesn't trigger magic";
  66  }
  67
  68  {
  69   local $@;
  70   my $b;
  71   eval { $b = $a };
  72   is $@, '', "get in thread $tid doesn't croak";
  73   is $b, 3,  "get in thread $tid returns the right thing";
  74   is $c, 1,  "get in thread $tid triggers magic";
  75  }
  76
  77  {
  78   local $@;
  79   my $d = eval { &Variable::Magic::getdata(\$a, $wiz) };
  80   is $@, '',       "getdata in thread $tid doesn't croak";
  81   is $d, 5 + $tid, "getdata in thread $tid returns the right thing";
  82   is $c, 1,        "getdata in thread $tid doesn't trigger magic";
  83  }
  84
  85  {
  86   local $@;
  87   eval { $a = 9 };
  88   is $@, '', "set in thread $tid (check opname) doesn't croak";
  89  }
  90
  91  if ($dispell) {
  92   {
  93    local $@;
  94    my $res = eval { &Variable::Magic::dispell(\$a, $wiz) };
  95    is $@, '', "dispell in thread $tid doesn't croak";
  96    is $c, 1,  "dispell in thread $tid doesn't trigger magic";
  97   }
  98
  99   {
 100    local $@;
 101    my $b;
 102    eval { $b = $a };
 103    is $@, '', "get in thread $tid after dispell doesn't croak";
 104    is $b, 9,  "get in thread $tid after dispell returns the right thing";
 105    is $c, 1,  "get in thread $tid after dispell doesn't trigger magic";
 106   }
 107  }
 108
 109  return 1;
 110 }
 111
 112 for my $dispell (1, 0) {
 113  {
 114   lock $destroyed;
 115   $destroyed = 0;
 116  }
 117
 118  my $completed = 0;
 119
 120  my @threads = map spawn(\&try, $dispell, $_), ('name') x 2, ('object') x 2;
 121  for my $thr (@threads) {
 122   my $res = $thr->join;
 123   $completed += $res if defined $res;
 124  }
 125
 126  {
 127   lock $destroyed;
 128   is $destroyed, (1 - $dispell) * $completed, 'destructors';
 129  }
 130 }