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 $wiz = eval {
  23   wizard data    => sub { $_[1] + threads->tid() },
  24          get     => sub { lock $c; ++$c; 0 },
  25          set     => sub {
  26                      my $op = $_[-1];
  27                      my $tid = threads->tid();
  28                      if ($op_info == VMG_OP_INFO_OBJECT) {
  29                       is_deeply { class => ref($op),   name => $op->name },
  30                                 { class => 'B::BINOP', name => 'sassign' },
  31                                 "op object in thread $tid is correct";
  32                      } else {
  33                       is $op, 'sassign', "op name in thread $tid is correct";
  34                      }
  35                      0
  36                     },
  37          free    => sub { lock $destroyed; ++$destroyed; 0 },
  38          op_info => $op_info
  39  };
  40  is($@,     '',    "wizard with op_info $op_info in main thread doesn't croak");
  41  isnt($wiz, undef, "wizard with op_info $op_info in main thread is defined");
  42  is($c,     0,     "wizard with op_info $op_info in main thread doesn't trigger magic");
  43
  44  return $wiz;
  45 }
  46
  47 sub try {
  48  my ($dispell, $wiz) = @_;
  49  my $tid = threads->tid();
  50  my $a   = 3;
  51  my $res = eval { cast $a, $wiz, sub { 5 }->() };
  52  is($@, '', "cast in thread $tid doesn't croak");
  53  my $b;
  54  eval { $b = $a };
  55  is($@, '', "get in thread $tid doesn't croak");
  56  is($b, 3,  "get in thread $tid returns the right thing");
  57  my $d = eval { getdata $a, $wiz };
  58  is($@, '',       "getdata in thread $tid doesn't croak");
  59  is($d, 5 + $tid, "getdata in thread $tid returns the right thing");
  60  eval { $a = 9 };
  61  is($@, '', "set in thread $tid (check opname) doesn't croak");
  62  if ($dispell) {
  63   $res = eval { dispell $a, $wiz };
  64   is($@, '', "dispell in thread $tid doesn't croak");
  65   undef $b;
  66   eval { $b = $a };
  67   is($@, '', "get in thread $tid after dispell doesn't croak");
  68   is($b, 9,  "get in thread $tid after dispell returns the right thing");
  69  }
  70  return; # Ugly if not here
  71 }
  72
  73 my $wiz_name = spawn_wiz VMG_OP_INFO_NAME;
  74 my $wiz_obj  = spawn_wiz VMG_OP_INFO_OBJECT;
  75
  76 for my $dispell (1, 0) {
  77  for my $wiz ($wiz_name, $wiz_obj) {
  78   {
  79    lock $c;
  80    $c = 0;
  81   }
  82   {
  83    lock $destroyed;
  84    $destroyed = 0;
  85   }
  86
  87   my @threads = map spawn(\&try, $dispell, $wiz), 1 .. 2;
  88   $_->join for @threads;
  89
  90   {
  91    lock $c;
  92    is $c, 2, "get triggered twice";
  93   }
  94   {
  95    lock $destroyed;
  96    is $destroyed, (1 - $dispell) * 2, 'destructors';
  97   }
  98  }
  99 }
 100
 101 {
 102  my @threads;
 103  my $flag : shared = 0;
 104  my $destroyed;
 105
 106  {
 107   my $wiz = wizard(
 108    set => sub {
 109     my $tid = threads->tid;
 110     pass "set callback called in thread $tid"
 111    },
 112    free => sub { ++$destroyed },
 113   );
 114
 115   my $var = 123;
 116   cast $var, $wiz;
 117
 118   @threads = map spawn(
 119    sub {
 120     my $tid = threads->tid;
 121     my $exp = 456 + $tid;
 122     {
 123      lock $flag;
 124      threads::shared::cond_wait($flag) until $flag;
 125     }
 126     $var = $exp;
 127     is $var, $exp, "\$var could be assigned to in thread $tid";
 128    }
 129   ), 1 .. 5;
 130  }
 131
 132  is $destroyed, 1, 'wizard is destroyed';
 133
 134  {
 135   lock $flag;
 136   $flag = 1;
 137   threads::shared::cond_broadcast($flag);
 138  }
 139
 140  $_->join for @threads;
 141 }