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