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
|
BEGIN {
chdir 't' if -d 't';
push @INC, '../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
}
use warnings;
use strict;
use threads;
use threads::shared;
use Hash::Util 'lock_keys';
# 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
print "1..14\n";
my $test : shared = 1;
sub is($$$) {
my ($got, $want, $desc) = @_;
unless ($got eq $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
#
#########################
$|++;
{
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;
$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 too be done, because an attempt was made to change a variable
# with the : unique attribute.
#
#########################
threads->new( sub {1} )->join;
my $not = eval { Config::myconfig() } ? '' : 'not ';
print "${not}ok $test - 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->new(
sub {
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++;
eval { $unique_hash{abc} = 1 };
print $@ =~ /disallowed/
? '' : 'not ', "ok $test # TODO $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') {
eval $decl;
print $@ =~
/^The 'unique' attribute may only be applied to 'our' variables/
? '' : 'not ', "ok $test - $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->new(\&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->new(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->new(sub { return scalar keys %h })->join;
is ($child, 1, "keys correct in child with restricted hash");
1;
|
