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