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