This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
threads 1.64 (repost)
[perl5.git] / ext / threads / t / problems.t
CommitLineData
0f1612a7
JH
1use strict;
2use warnings;
da46a8d0
AB
3
4BEGIN {
0f1612a7
JH
5 if ($ENV{'PERL_CORE'}){
6 chdir 't';
7 unshift @INC, '../lib';
8 }
9 use Config;
fc04eb16
JH
10 if (! $Config{'useithreads'}) {
11 print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
12 exit(0);
da46a8d0
AB
13 }
14}
15
0f1612a7
JH
16use ExtUtils::testlib;
17
58a3a76c
JH
18use threads;
19
0f1612a7 20BEGIN {
58a3a76c
JH
21 eval {
22 require threads::shared;
f3086ff0 23 threads::shared->import();
58a3a76c
JH
24 };
25 if ($@ || ! $threads::shared::threads_shared) {
26 print("1..0 # Skip: threads::shared not available\n");
27 exit(0);
28 }
29
0f1612a7
JH
30 $| = 1;
31 if ($] == 5.008) {
f2cba68d 32 print("1..11\n"); ### Number of tests that will be run ###
0f1612a7
JH
33 } else {
34 print("1..15\n"); ### Number of tests that will be run ###
35 }
36};
37
0f1612a7
JH
38print("ok 1 - Loaded\n");
39
40### Start of Testing ###
41
42no warnings 'deprecated'; # Suppress warnings related to :unique
43
94a66813 44use Hash::Util 'lock_keys';
997c206d 45
fc04eb16 46my $test :shared = 2;
997c206d 47
fc04eb16
JH
48# Note that we can't use Test::More here, as we would need to call is()
49# from within the DESTROY() function at global destruction time, and
50# parts of Test::* may have already been freed by then
51sub is($$$)
52{
997c206d 53 my ($got, $want, $desc) = @_;
f2cba68d 54 lock($test);
fc04eb16
JH
55 if ($got ne $want) {
56 print("# EXPECTED: $want\n");
57 print("# GOT: $got\n");
58 print("not ");
997c206d 59 }
fc04eb16 60 print("ok $test - $desc\n");
997c206d
DM
61 $test++;
62}
da46a8d0
AB
63
64
fc04eb16
JH
65# This tests for too much destruction which was caused by cloning stashes
66# on join which led to double the dataspace under 5.8.0
f2cba68d 67if ($] != 5.008)
fc04eb16
JH
68{
69 sub Foo::DESTROY
70 {
71 my $self = shift;
72 my ($package, $file, $line) = caller;
73 is(threads->tid(), $self->{tid}, "In destroy[$self->{tid}] it should be correct too" );
da46a8d0 74 }
fc04eb16
JH
75
76 my $foo = bless {tid => 0}, 'Foo';
77 my $bar = threads->create(sub {
78 is(threads->tid(), 1, "And tid be 1 here");
79 $foo->{tid} = 1;
80 return ($foo);
da46a8d0
AB
81 })->join();
82 $bar->{tid} = 0;
da46a8d0 83}
ad4404a3 84
fc04eb16 85
ad4404a3
EM
86# This tests whether we can call Config::myconfig after threads have been
87# started (interpreter cloned). 5.8.1 and 5.8.2 contained a bug that would
fc04eb16
JH
88# disallow that to be done because an attempt was made to change a variable
89# with the :unique attribute.
90
f2cba68d
JH
91{
92 lock($test);
93 if ($] == 5.008 || $] >= 5.008003) {
94 threads->create( sub {1} )->join;
95 my $not = eval { Config::myconfig() } ? '' : 'not ';
96 print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
97 } else {
98 print "ok $test # Skip Are we able to call Config::myconfig after clone\n";
99 }
100 $test++;
0f1612a7 101}
ad4404a3 102
fc04eb16 103
53c33732
DM
104# bugid 24383 - :unique hashes weren't being made readonly on interpreter
105# clone; check that they are.
106
107our $unique_scalar : unique;
108our @unique_array : unique;
109our %unique_hash : unique;
fc04eb16 110threads->create(sub {
f2cba68d 111 lock($test);
fc04eb16
JH
112 my $TODO = ":unique needs to be re-implemented in a non-broken way";
113 eval { $unique_scalar = 1 };
114 print $@ =~ /read-only/
115 ? '' : 'not ', "ok $test # TODO $TODO - unique_scalar\n";
116 $test++;
117 eval { $unique_array[0] = 1 };
118 print $@ =~ /read-only/
119 ? '' : 'not ', "ok $test # TODO $TODO - unique_array\n";
120 $test++;
0f1612a7
JH
121 if ($] >= 5.008003 && $^O ne 'MSWin32') {
122 eval { $unique_hash{abc} = 1 };
123 print $@ =~ /disallowed/
124 ? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
125 } else {
126 print("ok $test # Skip $TODO - unique_hash\n");
127 }
fc04eb16
JH
128 $test++;
129 })->join;
53c33732 130
371fce9b
DM
131# bugid #24940 :unique should fail on my and sub declarations
132
133for my $decl ('my $x : unique', 'sub foo : unique') {
f2cba68d
JH
134 {
135 lock($test);
136 if ($] >= 5.008005) {
137 eval $decl;
138 print $@ =~ /^The 'unique' attribute may only be applied to 'our' variables/
139 ? '' : 'not ', "ok $test - $decl\n";
140 } else {
141 print("ok $test # Skip $decl\n");
142 }
143 $test++;
0f1612a7 144 }
371fce9b
DM
145}
146
147
b23f1a86
DM
148# Returing a closure from a thread caused problems. If the last index in
149# the anon sub's pad wasn't for a lexical, then a core dump could occur.
150# Otherwise, there might be leaked scalars.
151
a6144651
DM
152# XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a
153# thread seems to crash win32
154
155# sub f {
156# my $x = "foo";
157# sub { $x."bar" };
158# }
159#
f4cc38af 160# my $string = threads->create(\&f)->join->();
a6144651
DM
161# print $string eq 'foobar' ? '' : 'not ', "ok $test - returning closure\n";
162# $test++;
b23f1a86 163
0f1612a7 164
94a66813
NC
165# Nothing is checking that total keys gets cloned correctly.
166
167my %h = (1,2,3,4);
fc04eb16 168is(keys(%h), 2, "keys correct in parent");
94a66813 169
fc04eb16
JH
170my $child = threads->create(sub { return (scalar(keys(%h))); })->join;
171is($child, 2, "keys correct in child");
94a66813 172
fc04eb16
JH
173lock_keys(%h);
174delete($h{1});
94a66813 175
fc04eb16 176is(keys(%h), 1, "keys correct in parent with restricted hash");
94a66813 177
fc04eb16
JH
178$child = threads->create(sub { return (scalar(keys(%h))); })->join;
179is($child, 1, "keys correct in child with restricted hash");
94a66813 180
fc04eb16 181# EOF