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