Commit | Line | Data |
---|---|---|
0f1612a7 JH |
1 | use strict; |
2 | use warnings; | |
f9dff5f5 AB |
3 | |
4 | BEGIN { | |
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 | ||
13 | use ExtUtils::testlib; | |
0f1612a7 | 14 | |
58a3a76c JH |
15 | use threads; |
16 | ||
fc04eb16 | 17 | BEGIN { |
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 | 26 | print("ok 1 - Loaded\n"); |
f9dff5f5 | 27 | |
fc04eb16 | 28 | ### Start of Testing ### |
f9dff5f5 AB |
29 | |
30 | sub 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 | ||
49 | sub 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 | 83 | my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n"); |
f9dff5f5 AB |
84 | $t->join->join; |
85 | } | |
86 | ||
87 | ||
88 | ||
89 | sub testsprintf { | |
90 | my $testno = shift; | |
91 | my $same = sprintf( "%0.f", $testno); | |
8abd20a8 | 92 | return $testno eq $same; |
f9dff5f5 AB |
93 | } |
94 | ||
95 | sub 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 | ||
136 | package Test1; | |
137 | ||
138 | use threads 'yield'; | |
139 | yield; | |
140 | main::ok(1); | |
141 | ||
142 | package 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 | ||
f5663432 | 164 | run_perl(prog => 'use threads 2.12;' . |
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 | 169 | is($?, 0, 'coredump in global destruction'); |
9c98058e | 170 | |
09576c7d JH |
171 | # Attempt to free unreferenced scalar... |
172 | fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via scalar'); | |
173 | use threads; | |
174 | my $test = sub {}; | |
175 | threads->create($test)->join(); | |
176 | print 'ok'; | |
177 | EOI | |
178 | ||
179 | # Attempt to free unreferenced scalar... | |
180 | fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via $_[0]'); | |
181 | use threads; | |
182 | sub thr { threads->new($_[0]); } | |
183 | thr(sub { })->join; | |
184 | print 'ok'; | |
185 | EOI | |
186 | ||
863e9b4a DM |
187 | # [perl #45053] Memory corruption from eval return in void context |
188 | fresh_perl_is(<<'EOI', 'ok', { }, 'void eval return'); | |
189 | use threads; | |
190 | threads->create(sub { eval '1' }); | |
191 | $_->join() for threads->list; | |
192 | print 'ok'; | |
193 | EOI | |
194 | ||
9660f481 | 195 | # test CLONE_SKIP() functionality |
821f5ffa JH |
196 | SKIP: { |
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 S |
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 |
327 | exit(0); |
328 | ||
0f1612a7 | 329 | # EOF |