t/41-clone.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use lib 't/lib';
   7 use Variable::Magic::TestThreads;
   8
   9 use Test::More 'no_plan';
  10
  11 use Variable::Magic qw<
  12  wizard cast dispell getdata
  13  VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT
  14 >;
  15
  16 my $destroyed : shared = 0;
  17 my $c         : shared = 0;
  18
  19 sub spawn_wiz {
  20  my ($op_info) = @_;
  21
  22  my $desc = "wizard with op_info $op_info in main thread";
  23
  24  local $@;
  25  my $wiz = eval {
  26   wizard(
  27    data    => sub { $_[1] + threads->tid() },
  28    get     => sub { lock $c; ++$c; 0 },
  29    set     => sub {
  30     my $op = $_[-1];
  31     my $tid = threads->tid();
  32
  33     if ($op_info == VMG_OP_INFO_OBJECT) {
  34      is_deeply { class => ref($op),   name => $op->name },
  35                { class => 'B::BINOP', name => 'sassign' },
  36                "op object in thread $tid is correct";
  37     } else {
  38      is $op, 'sassign', "op name in thread $tid is correct";
  39     }
  40
  41     return 0
  42    },
  43    free    => sub { lock $destroyed; ++$destroyed; 0 },
  44    op_info => $op_info,
  45   );
  46  };
  47  is $@,     '',    "$desc doesn't croak";
  48  isnt $wiz, undef, "$desc is defined";
  49  is $c,     0,     "$desc doesn't trigger magic";
  50
  51  return $wiz;
  52 }
  53
  54 sub try {
  55  my ($dispell, $wiz) = @_;
  56  my $tid = threads->tid;
  57
  58  my $a = 3;
  59
  60  {
  61   local $@;
  62   my $res = eval { cast $a, $wiz, sub { 5 }->() };
  63   is $@, '', "cast in thread $tid doesn't croak";
  64  }
  65
  66  {
  67   local $@;
  68   my $b;
  69   eval { $b = $a };
  70   is $@, '', "get in thread $tid doesn't croak";
  71   is $b, 3,  "get in thread $tid returns the right thing";
  72  }
  73
  74  {
  75   local $@;
  76   my $d = eval { getdata $a, $wiz };
  77   is $@, '',       "getdata in thread $tid doesn't croak";
  78   is $d, 5 + $tid, "getdata in thread $tid returns the right thing";
  79  }
  80
  81  {
  82   local $@;
  83   eval { $a = 9 };
  84   is $@, '', "set in thread $tid (check opname) doesn't croak";
  85  }
  86
  87  if ($dispell) {
  88   {
  89    local $@;
  90    my $res = eval { dispell $a, $wiz };
  91    is $@, '', "dispell in thread $tid doesn't croak";
  92   }
  93
  94   {
  95    local $@;
  96    my $b;
  97    eval { $b = $a };
  98    is $@, '', "get in thread $tid after dispell doesn't croak";
  99    is $b, 9,  "get in thread $tid after dispell returns the right thing";
 100   }
 101  }
 102
 103  return;
 104 }
 105
 106 my $wiz_name = spawn_wiz VMG_OP_INFO_NAME;
 107 my $wiz_obj  = spawn_wiz VMG_OP_INFO_OBJECT;
 108
 109 for my $dispell (1, 0) {
 110  for my $wiz ($wiz_name, $wiz_obj) {
 111   {
 112    lock $c;
 113    $c = 0;
 114   }
 115   {
 116    lock $destroyed;
 117    $destroyed = 0;
 118   }
 119
 120   my @threads = map spawn(\&try, $dispell, $wiz), 1 .. 2;
 121   $_->join for @threads;
 122
 123   {
 124    lock $c;
 125    is $c, 2, "get triggered twice";
 126   }
 127   {
 128    lock $destroyed;
 129    is $destroyed, (1 - $dispell) * 2, 'destructors';
 130   }
 131  }
 132 }
 133
 134 {
 135  my @threads;
 136  my $flag : shared = 0;
 137  my $destroyed;
 138
 139  {
 140   my $wiz = wizard(
 141    set => sub {
 142     my $tid = threads->tid;
 143     pass "set callback called in thread $tid"
 144    },
 145    free => sub { ++$destroyed },
 146   );
 147
 148   my $var = 123;
 149   cast $var, $wiz;
 150
 151   @threads = map spawn(
 152    sub {
 153     my $tid = threads->tid;
 154     my $exp = 456 + $tid;
 155     {
 156      lock $flag;
 157      threads::shared::cond_wait($flag) until $flag;
 158     }
 159     $var = $exp;
 160     is $var, $exp, "\$var could be assigned to in thread $tid";
 161    }
 162   ), 1 .. 5;
 163  }
 164
 165  is $destroyed, 1, 'wizard is destroyed';
 166
 167  {
 168   lock $flag;
 169   $flag = 1;
 170   threads::shared::cond_broadcast($flag);
 171  }
 172
 173  $_->join for @threads;
 174 }