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