5 if ($ENV{'PERL_CORE'}){
7 unshift @INC, '../lib';
10 unless ($Config{'useithreads'}) {
11 print "1..0 # Skip: no useithreads\n";
16 use ExtUtils::testlib;
21 print("1..14\n"); ### Number of tests that will be run ###
23 print("1..15\n"); ### Number of tests that will be run ###
29 print("ok 1 - Loaded\n");
31 ### Start of Testing ###
33 no warnings 'deprecated'; # Suppress warnings related to :unique
35 use Hash::Util 'lock_keys';
37 # Note that we can't use Test::More here, as we would need to
38 # call is() from within the DESTROY() function at global destruction time,
39 # and parts of Test::* may have already been freed by then
41 my $test : shared = 2;
44 my ($got, $want, $desc) = @_;
45 unless ($got eq $want) {
46 print "# EXPECTED: $want\n";
47 print "# GOT: $got\n";
50 print "ok $test - $desc\n";
56 # This tests for too much destruction
57 # which was caused by cloning stashes
58 # on join which led to double the dataspace
60 #########################
65 my ($package, $file, $line) = caller;
66 is(threads->tid(),$self->{tid},
67 "In destroy[$self->{tid}] it should be correct too" )
70 $foo = bless {tid => 0}, 'Foo';
71 my $bar = threads->create(sub {
72 is(threads->tid(),1, "And tid be 1 here");
80 # This tests whether we can call Config::myconfig after threads have been
81 # started (interpreter cloned). 5.8.1 and 5.8.2 contained a bug that would
82 # disallow that too be done, because an attempt was made to change a variable
83 # with the : unique attribute.
85 #########################
87 if ($] == 5.008 || $] >= 5.008003) {
88 threads->new( sub {1} )->join;
89 my $not = eval { Config::myconfig() } ? '' : 'not ';
90 print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
92 print "ok $test # Skip Are we able to call Config::myconfig after clone\n";
96 # bugid 24383 - :unique hashes weren't being made readonly on interpreter
97 # clone; check that they are.
99 our $unique_scalar : unique;
100 our @unique_array : unique;
101 our %unique_hash : unique;
104 my $TODO = ":unique needs to be re-implemented in a non-broken way";
105 eval { $unique_scalar = 1 };
106 print $@ =~ /read-only/
107 ? '' : 'not ', "ok $test # TODO $TODO unique_scalar\n";
109 eval { $unique_array[0] = 1 };
110 print $@ =~ /read-only/
111 ? '' : 'not ', "ok $test # TODO $TODO - unique_array\n";
113 if ($] >= 5.008003 && $^O ne 'MSWin32') {
114 eval { $unique_hash{abc} = 1 };
115 print $@ =~ /disallowed/
116 ? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
118 print("ok $test # Skip $TODO - unique_hash\n");
124 # bugid #24940 :unique should fail on my and sub declarations
126 for my $decl ('my $x : unique', 'sub foo : unique') {
127 if ($] >= 5.008005) {
129 print $@ =~ /^The 'unique' attribute may only be applied to 'our' variables/
130 ? '' : 'not ', "ok $test - $decl\n";
132 print("ok $test # Skip $decl\n");
138 # Returing a closure from a thread caused problems. If the last index in
139 # the anon sub's pad wasn't for a lexical, then a core dump could occur.
140 # Otherwise, there might be leaked scalars.
142 # XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a
143 # thread seems to crash win32
150 # my $string = threads->new(\&f)->join->();
151 # print $string eq 'foobar' ? '' : 'not ', "ok $test - returning closure\n";
155 # Nothing is checking that total keys gets cloned correctly.
158 is (keys %h, 2, "keys correct in parent");
160 my $child = threads->new(sub { return scalar keys %h })->join;
161 is ($child, 2, "keys correct in child");
166 is (keys %h, 1, "keys correct in parent with restricted hash");
168 $child = threads->new(sub { return scalar keys %h })->join;
169 is ($child, 1, "keys correct in child with restricted hash");