This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH-revised] ext/Win32/t/Unicode.t failures on FAT32 under Cygwin
[perl5.git] / ext / threads / t / thread.t
CommitLineData
0f1612a7
JH
1use strict;
2use warnings;
f9dff5f5
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);
f9dff5f5 13 }
0f1612a7
JH
14
15 require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
f9dff5f5
AB
16}
17
18use ExtUtils::testlib;
0f1612a7 19
58a3a76c
JH
20use threads;
21
fc04eb16 22BEGIN {
58a3a76c
JH
23 eval {
24 require threads::shared;
25 import threads::shared;
26 };
27 if ($@ || ! $threads::shared::threads_shared) {
28 print("1..0 # Skip: threads::shared not available\n");
29 exit(0);
30 }
31
fc04eb16
JH
32 $| = 1;
33 print("1..31\n"); ### Number of tests that will be run ###
34};
35
fc04eb16 36print("ok 1 - Loaded\n");
f9dff5f5 37
fc04eb16 38### Start of Testing ###
f9dff5f5
AB
39
40sub content {
41 print shift;
42 return shift;
43}
44{
f4cc38af 45 my $t = threads->create(\&content, "ok 2\n", "ok 3\n", 1..1000);
f9dff5f5
AB
46 print $t->join();
47}
48{
49 my $lock : shared;
50 my $t;
51 {
fc04eb16
JH
52 lock($lock);
53 $t = threads->create(sub { lock($lock); print "ok 5\n"});
54 print "ok 4\n";
f9dff5f5
AB
55 }
56 $t->join();
57}
58
59sub dorecurse {
60 my $val = shift;
61 my $ret;
74bf223e 62 print $val;
f9dff5f5 63 if(@_) {
fc04eb16
JH
64 $ret = threads->create(\&dorecurse, @_);
65 $ret->join;
f9dff5f5
AB
66 }
67}
68{
f4cc38af 69 my $t = threads->create(\&dorecurse, map { "ok $_\n" } 6..10);
74bf223e 70 $t->join();
f9dff5f5
AB
71}
72
73{
74 # test that sleep lets other thread run
f4cc38af 75 my $t = threads->create(\&dorecurse, "ok 11\n");
da32f63e 76 threads->yield; # help out non-preemptive thread implementations
f9dff5f5 77 sleep 1;
74bf223e
JH
78 print "ok 12\n";
79 $t->join();
f9dff5f5
AB
80}
81{
82 my $lock : shared;
83 sub islocked {
fc04eb16
JH
84 lock($lock);
85 my $val = shift;
86 my $ret;
87 print $val;
88 if (@_) {
89 $ret = threads->create(\&islocked, shift);
90 }
91 return $ret;
f9dff5f5 92 }
f4cc38af 93my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n");
f9dff5f5
AB
94$t->join->join;
95}
96
97
98
99sub testsprintf {
100 my $testno = shift;
101 my $same = sprintf( "%0.f", $testno);
8abd20a8 102 return $testno eq $same;
f9dff5f5
AB
103}
104
105sub threaded {
8abd20a8 106 my ($string, $string_end) = @_;
f9dff5f5
AB
107
108 # Do the match, saving the output in appropriate variables
109 $string =~ /(.*)(is)(.*)/;
110 # Yield control, allowing the other thread to fill in the match variables
111 threads->yield();
112 # Examine the match variable contents; on broken perls this fails
8abd20a8 113 return $3 eq $string_end;
f9dff5f5
AB
114}
115
116
117{
74bf223e 118 curr_test(15);
8abd20a8 119
f4cc38af
JH
120 my $thr1 = threads->create(\&testsprintf, 15);
121 my $thr2 = threads->create(\&testsprintf, 16);
f9dff5f5
AB
122
123 my $short = "This is a long string that goes on and on.";
124 my $shorte = " a long string that goes on and on.";
125 my $long = "This is short.";
126 my $longe = " short.";
127 my $foo = "This is bar bar bar.";
128 my $fooe = " bar bar bar.";
8abd20a8
JH
129 my $thr3 = new threads \&threaded, $short, $shorte;
130 my $thr4 = new threads \&threaded, $long, $longe;
74bf223e
JH
131 my $thr5 = new threads \&testsprintf, 19;
132 my $thr6 = new threads \&testsprintf, 20;
8abd20a8
JH
133 my $thr7 = new threads \&threaded, $foo, $fooe;
134
135 ok($thr1->join());
136 ok($thr2->join());
137 ok($thr3->join());
138 ok($thr4->join());
139 ok($thr5->join());
140 ok($thr6->join());
141 ok($thr7->join());
f9dff5f5 142}
38875929
DM
143
144# test that 'yield' is importable
145
146package Test1;
147
148use threads 'yield';
149yield;
150main::ok(1);
151
152package main;
153
154
155# test async
156
157{
158 my $th = async {return 1 };
159 ok($th);
160 ok($th->join());
161}
9c98058e 162{
4dcb9e53 163 # There is a miniscule chance this test case may falsely fail
4acc73f2 164 # since it tests using rand()
9c98058e
AB
165 my %rand : shared;
166 rand(10);
f4cc38af 167 threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
9c98058e 168 $_->join foreach threads->list;
4dcb9e53 169 ok((keys %rand >= 23), "Check that rand() is randomized in new threads");
9c98058e
AB
170}
171
4e380990
DM
172# bugid #24165
173
c527c90b 174run_perl(prog => 'use threads 1.63;' .
60bd5ef6
RGS
175 'sub a{threads->create(shift)} $t = a sub{};' .
176 '$t->tid; $t->join; $t->tid',
69a9b4b8
RGS
177 nolib => ($ENV{PERL_CORE}) ? 0 : 1,
178 switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
4e380990 179is($?, 0, 'coredump in global destruction');
9c98058e 180
9660f481 181# test CLONE_SKIP() functionality
0f1612a7 182if ($] >= 5.008007) {
9660f481
DM
183 my %c : shared;
184 my %d : shared;
185
186 # ---
187
188 package A;
189 sub CLONE_SKIP { $c{"A-$_[0]"}++; 1; }
190 sub DESTROY { $d{"A-". ref $_[0]}++ }
191
192 package A1;
193 our @ISA = qw(A);
194 sub CLONE_SKIP { $c{"A1-$_[0]"}++; 1; }
195 sub DESTROY { $d{"A1-". ref $_[0]}++ }
196
197 package A2;
198 our @ISA = qw(A1);
199
200 # ---
201
202 package B;
203 sub CLONE_SKIP { $c{"B-$_[0]"}++; 0; }
204 sub DESTROY { $d{"B-" . ref $_[0]}++ }
205
206 package B1;
207 our @ISA = qw(B);
208 sub CLONE_SKIP { $c{"B1-$_[0]"}++; 1; }
209 sub DESTROY { $d{"B1-" . ref $_[0]}++ }
210
211 package B2;
212 our @ISA = qw(B1);
213
214 # ---
215
216 package C;
217 sub CLONE_SKIP { $c{"C-$_[0]"}++; 1; }
218 sub DESTROY { $d{"C-" . ref $_[0]}++ }
219
220 package C1;
221 our @ISA = qw(C);
222 sub CLONE_SKIP { $c{"C1-$_[0]"}++; 0; }
223 sub DESTROY { $d{"C1-" . ref $_[0]}++ }
224
225 package C2;
226 our @ISA = qw(C1);
227
228 # ---
229
230 package D;
231 sub DESTROY { $d{"D-" . ref $_[0]}++ }
232
233 package D1;
234 our @ISA = qw(D);
235
236 package main;
237
238 {
fc04eb16
JH
239 my @objs;
240 for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) {
241 push @objs, bless [], $class;
242 }
243
244 sub f {
245 my $depth = shift;
246 my $cloned = ""; # XXX due to recursion, doesn't get initialized
247 $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs;
248 is($cloned, ($depth ? '00010001111' : '11111111111'),
249 "objs clone skip at depth $depth");
250 threads->create( \&f, $depth+1)->join if $depth < 2;
251 @objs = ();
252 }
253 f(0);
9660f481
DM
254 }
255
256 curr_test(curr_test()+2);
257 ok(eq_hash(\%c,
fc04eb16
JH
258 {
259 qw(
260 A-A 2
261 A1-A1 2
262 A1-A2 2
263 B-B 2
264 B1-B1 2
265 B1-B2 2
266 C-C 2
267 C1-C1 2
268 C1-C2 2
269 )
270 }),
271 "counts of calls to CLONE_SKIP");
9660f481 272 ok(eq_hash(\%d,
fc04eb16
JH
273 {
274 qw(
275 A-A 1
276 A1-A1 1
277 A1-A2 1
278 B-B 3
279 B1-B1 1
280 B1-B2 1
281 C-C 1
282 C1-C1 3
283 C1-C2 3
284 D-D 3
285 D-D1 3
286 )
287 }),
288 "counts of calls to DESTROY");
0f1612a7
JH
289
290} else {
291 print("ok 27 # Skip objs clone skip at depth 0\n");
292 print("ok 28 # Skip objs clone skip at depth 1\n");
293 print("ok 29 # Skip objs clone skip at depth 2\n");
294 print("ok 30 # Skip counts of calls to CLONE_SKIP\n");
295 print("ok 31 # Skip counts of calls to DESTROY\n");
9660f481 296}
38875929 297
0f1612a7 298# EOF