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
195
196
197
|
use strict;
use warnings;
BEGIN {
if ($ENV{'PERL_CORE'}){
chdir 't';
unshift @INC, '../lib';
}
use Config;
if (! $Config{'useithreads'}) {
print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
exit(0);
}
}
use ExtUtils::testlib;
use threads;
BEGIN {
eval {
require threads::shared;
threads::shared->import();
};
if ($@ || ! $threads::shared::threads_shared) {
print("1..0 # Skip: threads::shared not available\n");
exit(0);
}
$| = 1;
if ($] == 5.008) {
print("1..12\n"); ### Number of tests that will be run ###
} else {
print("1..16\n"); ### Number of tests that will be run ###
}
};
print("ok 1 - Loaded\n");
### Start of Testing ###
no warnings 'deprecated'; # Suppress warnings related to :unique
use Hash::Util 'lock_keys';
my $test :shared = 2;
# Note that we can't use Test::More here, as we would need to call is()
# from within the DESTROY() function at global destruction time, and
# parts of Test::* may have already been freed by then
sub is($$$)
{
my ($got, $want, $desc) = @_;
lock($test);
if ($got ne $want) {
print("# EXPECTED: $want\n");
print("# GOT: $got\n");
print("not ");
}
print("ok $test - $desc\n");
$test++;
}
# This tests for too much destruction which was caused by cloning stashes
# on join which led to double the dataspace under 5.8.0
if ($] != 5.008)
{
sub Foo::DESTROY
{
my $self = shift;
my ($package, $file, $line) = caller;
is(threads->tid(), $self->{tid}, "In destroy[$self->{tid}] it should be correct too" );
}
my $foo = bless {tid => 0}, 'Foo';
my $bar = threads->create(sub {
is(threads->tid(), 1, "And tid be 1 here");
$foo->{tid} = 1;
return ($foo);
})->join();
$bar->{tid} = 0;
}
# This tests whether we can call Config::myconfig after threads have been
# started (interpreter cloned). 5.8.1 and 5.8.2 contained a bug that would
# disallow that to be done because an attempt was made to change a variable
# with the :unique attribute.
{
lock($test);
if ($] == 5.008 || $] >= 5.008003) {
threads->create( sub {1} )->join;
my $not = eval { Config::myconfig() } ? '' : 'not ';
print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
} else {
print "ok $test # Skip Are we able to call Config::myconfig after clone\n";
}
$test++;
}
# bugid 24383 - :unique hashes weren't being made readonly on interpreter
# clone; check that they are.
our $unique_scalar : unique;
our @unique_array : unique;
our %unique_hash : unique;
threads->create(sub {
lock($test);
my $TODO = ":unique needs to be re-implemented in a non-broken way";
eval { $unique_scalar = 1 };
print $@ =~ /read-only/
? '' : 'not ', "ok $test # TODO $TODO - unique_scalar\n";
$test++;
eval { $unique_array[0] = 1 };
print $@ =~ /read-only/
? '' : 'not ', "ok $test # TODO $TODO - unique_array\n";
$test++;
if ($] >= 5.008003 && $^O ne 'MSWin32') {
eval { $unique_hash{abc} = 1 };
print $@ =~ /disallowed/
? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
} else {
print("ok $test # Skip $TODO - unique_hash\n");
}
$test++;
})->join;
# bugid #24940 :unique should fail on my and sub declarations
for my $decl ('my $x : unique', 'sub foo : unique') {
{
lock($test);
if ($] >= 5.008005) {
eval $decl;
print $@ =~ /^The 'unique' attribute may only be applied to 'our' variables/
? '' : 'not ', "ok $test - $decl\n";
} else {
print("ok $test # Skip $decl\n");
}
$test++;
}
}
# Returing a closure from a thread caused problems. If the last index in
# the anon sub's pad wasn't for a lexical, then a core dump could occur.
# Otherwise, there might be leaked scalars.
# XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a
# thread seems to crash win32
# sub f {
# my $x = "foo";
# sub { $x."bar" };
# }
#
# my $string = threads->create(\&f)->join->();
# print $string eq 'foobar' ? '' : 'not ', "ok $test - returning closure\n";
# $test++;
# Nothing is checking that total keys gets cloned correctly.
my %h = (1,2,3,4);
is(keys(%h), 2, "keys correct in parent");
my $child = threads->create(sub { return (scalar(keys(%h))); })->join;
is($child, 2, "keys correct in child");
lock_keys(%h);
delete($h{1});
is(keys(%h), 1, "keys correct in parent with restricted hash");
$child = threads->create(sub { return (scalar(keys(%h))); })->join;
is($child, 1, "keys correct in child with restricted hash");
# [perl #45053] Memory corruption with heavy module loading in threads
#
# run-time usage of newCONSTSUB (as done by the IO boot code) wasn't
# thread-safe - got occasional coredumps or malloc corruption
{
my @t;
push @t, threads->create( sub { require IO }) for 1..100;
$_->join for @t;
print("ok $test - [perl #45053]\n");
$test++;
}
# EOF
|
