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