This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
From #43633: Cwd::cwd() use in File::Spec::Unix use causes unnecessary fork()
[perl5.git] / ext / threads / t / problems.t
1 use strict;
2 use warnings;
3
4 BEGIN {
5     if ($ENV{'PERL_CORE'}){
6         chdir 't';
7         unshift @INC, '../lib';
8     }
9     use Config;
10     if (! $Config{'useithreads'}) {
11         print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
12         exit(0);
13     }
14 }
15
16 use ExtUtils::testlib;
17
18 use threads;
19
20 BEGIN {
21     eval {
22         require threads::shared;
23         import threads::shared;
24     };
25     if ($@ || ! $threads::shared::threads_shared) {
26         print("1..0 # Skip: threads::shared not available\n");
27         exit(0);
28     }
29
30     $| = 1;
31     if ($] == 5.008) {
32         print("1..11\n");   ### Number of tests that will be run ###
33     } else {
34         print("1..15\n");   ### Number of tests that will be run ###
35     }
36 };
37
38 print("ok 1 - Loaded\n");
39
40 ### Start of Testing ###
41
42 no warnings 'deprecated';       # Suppress warnings related to :unique
43
44 use Hash::Util 'lock_keys';
45
46 my $test :shared = 2;
47
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
51 sub is($$$)
52 {
53     my ($got, $want, $desc) = @_;
54     lock($test);
55     if ($got ne $want) {
56         print("# EXPECTED: $want\n");
57         print("# GOT:      $got\n");
58         print("not ");
59     }
60     print("ok $test - $desc\n");
61     $test++;
62 }
63
64
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
67 if ($] != 5.008)
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" );
74     }
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);
81     })->join();
82     $bar->{tid} = 0;
83 }
84
85
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
88 # disallow that to be done because an attempt was made to change a variable
89 # with the :unique attribute.
90
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++;
101 }
102
103
104 # bugid 24383 - :unique hashes weren't being made readonly on interpreter
105 # clone; check that they are.
106
107 our $unique_scalar : unique;
108 our @unique_array : unique;
109 our %unique_hash : unique;
110 threads->create(sub {
111         lock($test);
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++;
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         }
128         $test++;
129     })->join;
130
131 # bugid #24940 :unique should fail on my and sub declarations
132
133 for my $decl ('my $x : unique', 'sub foo : unique') {
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++;
144     }
145 }
146
147
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
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
160 # my $string = threads->create(\&f)->join->();
161 # print $string eq 'foobar' ?  '' : 'not ', "ok $test - returning closure\n";
162 # $test++;
163
164
165 # Nothing is checking that total keys gets cloned correctly.
166
167 my %h = (1,2,3,4);
168 is(keys(%h), 2, "keys correct in parent");
169
170 my $child = threads->create(sub { return (scalar(keys(%h))); })->join;
171 is($child, 2, "keys correct in child");
172
173 lock_keys(%h);
174 delete($h{1});
175
176 is(keys(%h), 1, "keys correct in parent with restricted hash");
177
178 $child = threads->create(sub { return (scalar(keys(%h))); })->join;
179 is($child, 1, "keys correct in child with restricted hash");
180
181 # EOF