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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
#!/usr/local/bin/perl -w
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
@INC = '../lib';
} elsif (!grep /blib/, @INC) {
chdir 't' if -d 't';
unshift @INC, ('../blib/lib', '../blib/arch');
}
}
BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing!
use forks; # must be done _before_ Test::More which loads real threads.pm
use forks::shared;
diag( <<EOD );
The following tests check that blessing shared variables is fully transparent.
EOD
# "Unpatch" Test::More, who internally tries to disable threads
BEGIN {
no warnings 'redefine';
if ($] < 5.008001) {
require forks::shared::global_filter;
import forks::shared::global_filter 'Test::Builder';
require Test::Builder;
*Test::Builder::share = \&threads::shared::share;
*Test::Builder::lock = \&threads::shared::lock;
Test::Builder->new->reset;
}
}
# Patch Test::Builder to add fork-thread awareness
{
no warnings 'redefine';
my $_sanity_check_old = \&Test::Builder::_sanity_check;
*Test::Builder::_sanity_check = sub {
my $self = $_[0];
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
if( $self->{Original_Pid} != $$ ) {
return;
}
$_sanity_check_old->(@_);
};
}
use Test::More tests => 64;
use strict;
use warnings;
my $dummy = {};
bless ($dummy, 'simple');
ok(ref($dummy) eq 'simple', "regular blessing still works");
my ($hobj, $aobj, $sobj) : shared;
$hobj = &share({});
$aobj = &share([]);
my $sref = \do{ my $x };
share($sref);
$sobj = $sref;
threads->new(sub {
# Bless objects
bless $hobj, 'foo';
bless $aobj, 'bar';
bless $sobj, 'baz';
# Add data to objects
$$aobj[0] = bless(&share({}), 'yin');
$$aobj[1] = bless(&share([]), 'yang');
$$aobj[2] = $sobj;
$$hobj{'hash'} = bless(&share({}), 'yin');
$$hobj{'array'} = bless(&share([]), 'yang');
$$hobj{'scalar'} = $sobj;
$$sobj = 3;
# Test objects in child thread
ok(ref($hobj) eq 'foo', "hash blessing does work");
ok(ref($aobj) eq 'bar', "array blessing does work");
ok(ref($sobj) eq 'baz', "scalar blessing does work");
ok($$sobj eq '3', "scalar contents okay");
ok(ref($$aobj[0]) eq 'yin', "blessed hash in array");
ok(ref($$aobj[1]) eq 'yang', "blessed array in array");
ok(ref($$aobj[2]) eq 'baz', "blessed scalar in array");
ok(${$$aobj[2]} eq '3', "blessed scalar in array contents");
ok(ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash");
ok(ref($$hobj{'array'}) eq 'yang', "blessed array in hash");
ok(ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash");
ok(${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents");
})->join;
# Test objects in parent thread
ok(ref($hobj) eq 'foo', "hash blessing does work");
ok(ref($aobj) eq 'bar', "array blessing does work");
ok(ref($sobj) eq 'baz', "scalar blessing does work");
ok($$sobj eq '3', "scalar contents okay");
ok(ref($$aobj[0]) eq 'yin', "blessed hash in array");
ok(ref($$aobj[1]) eq 'yang', "blessed array in array");
ok(ref($$aobj[2]) eq 'baz', "blessed scalar in array");
ok(${$$aobj[2]} eq '3', "blessed scalar in array contents");
ok(ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash");
ok(ref($$hobj{'array'}) eq 'yang', "blessed array in hash");
ok(ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash");
ok(${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents");
threads->new(sub {
# Rebless objects
bless $hobj, 'oof';
bless $aobj, 'rab';
bless $sobj, 'zab';
my $data = $$aobj[0];
bless $data, 'niy';
$$aobj[0] = $data;
$data = $$aobj[1];
bless $data, 'gnay';
$$aobj[1] = $data;
$data = $$hobj{'hash'};
bless $data, 'niy';
$$hobj{'hash'} = $data;
$data = $$hobj{'array'};
bless $data, 'gnay';
$$hobj{'array'} = $data;
$$sobj = 'test';
})->join;
# Test reblessing
ok(ref($hobj) eq 'oof', "hash reblessing does work");
ok(ref($aobj) eq 'rab', "array reblessing does work");
ok(ref($sobj) eq 'zab', "scalar reblessing does work");
ok($$sobj eq 'test', "scalar contents okay");
ok(ref($$aobj[0]) eq 'niy', "reblessed hash in array");
ok(ref($$aobj[1]) eq 'gnay', "reblessed array in array");
ok(ref($$aobj[2]) eq 'zab', "reblessed scalar in array");
ok(${$$aobj[2]} eq 'test', "reblessed scalar in array contents");
ok(ref($$hobj{'hash'}) eq 'niy', "reblessed hash in hash");
ok(ref($$hobj{'array'}) eq 'gnay', "reblessed array in hash");
ok(ref($$hobj{'scalar'}) eq 'zab', "reblessed scalar in hash");
ok(${$$hobj{'scalar'}} eq 'test', "reblessed scalar in hash contents");
#36
ok(UNIVERSAL::isa($hobj, 'oof') == 1, "hash object with UNIVERSAL::isa does work");
ok(UNIVERSAL::isa($aobj, 'rab') == 1, "array object with UNIVERSAL::isa does work");
ok(UNIVERSAL::isa($sobj, 'zab') == 1, "scalar object with UNIVERSAL::isa does work");
ok(UNIVERSAL::isa($$aobj[0], 'niy') == 1, "hash in array object with UNIVERSAL::isa does work");
ok(UNIVERSAL::isa($$aobj[1], 'gnay') == 1, "array in array object with UNIVERSAL::isa does work");
ok(UNIVERSAL::isa($$aobj[2], 'zab') == 1, "scalar in array object with UNIVERSAL::isa does work");
ok(UNIVERSAL::isa($$hobj{'hash'}, 'niy') == 1, "hash in hash object with UNIVERSAL::isa does work");
ok(UNIVERSAL::isa($$hobj{'array'}, 'gnay') == 1, "array in hash object with UNIVERSAL::isa does work");
ok(UNIVERSAL::isa($$hobj{'scalar'}, 'zab') == 1, "scalar in hash object with UNIVERSAL::isa does work");
ok($hobj->isa('oof') == 1, "hash object method isa() does work");
ok($aobj->isa('rab') == 1, "array object method isa() does work");
ok($sobj->isa('zab') == 1, "scalar object method isa() does work");
ok($$aobj[0]->isa('niy') == 1, "hash in array object method isa() does work");
ok($$aobj[1]->isa('gnay') == 1, "array in array object method isa() does work");
ok($$aobj[2]->isa('zab') == 1, "scalar in array object method isa() does work");
ok($$hobj{'hash'}->isa('niy') == 1, "hash in hash object method isa() does work");
ok($$hobj{'array'}->isa('gnay') == 1, "array in hash object method isa() does work");
ok($$hobj{'scalar'}->isa('zab') == 1, "scalar in hash object method isa() does work");
sub oof::test_me { return "yes1"; }
sub rab::test_me { return "yes2"; }
sub zab::test_me { return "yes3"; }
sub niy::test_me { return "yes4"; }
sub gnay::test_me { return "yes5"; }
ok($hobj->test_me eq "yes1", "hash object method does work");
ok($aobj->test_me eq "yes2", "array object method does work");
ok($sobj->test_me eq "yes3", "scalar object method does work");
ok($$aobj[0]->test_me eq "yes4", "hash in array object method does work");
ok($$aobj[1]->test_me eq "yes5", "array in array object method does work");
ok($$aobj[2]->test_me eq "yes3", "scalar in array object method does work");
ok($$hobj{'hash'}->test_me eq "yes4", "hash in hash object method does work");
ok($$hobj{'array'}->test_me eq "yes5", "array in hash object method does work");
ok($$hobj{'scalar'}->test_me eq "yes3", "scalar in hash object method does work");
1;
|
