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