Commit | Line | Data |
---|---|---|
0f1612a7 JH |
1 | use strict; |
2 | use warnings; | |
f9dff5f5 AB |
3 | |
4 | BEGIN { | |
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 | ||
18 | use ExtUtils::testlib; | |
0f1612a7 | 19 | |
9660f481 | 20 | BEGIN { $| = 1; print "1..31\n" }; |
f9dff5f5 AB |
21 | use threads; |
22 | use threads::shared; | |
23 | ||
24 | print "ok 1\n"; | |
25 | ||
26 | sub 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 | ||
45 | sub 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 | 79 | my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n"); |
f9dff5f5 AB |
80 | $t->join->join; |
81 | } | |
82 | ||
83 | ||
84 | ||
85 | sub testsprintf { | |
86 | my $testno = shift; | |
87 | my $same = sprintf( "%0.f", $testno); | |
8abd20a8 | 88 | return $testno eq $same; |
f9dff5f5 AB |
89 | } |
90 | ||
91 | sub 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 | ||
132 | package Test1; | |
133 | ||
134 | use threads 'yield'; | |
135 | yield; | |
136 | main::ok(1); | |
137 | ||
138 | package 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 | ||
163 | run_perl(prog => | |
f4cc38af | 164 | 'use threads; sub a{threads->create(shift)} $t = a sub{}; $t->tid; $t->join; $t->tid'); |
4e380990 | 165 | is($?, 0, 'coredump in global destruction'); |
9c98058e | 166 | |
9660f481 | 167 | # test CLONE_SKIP() functionality |
0f1612a7 | 168 | if ($] >= 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 |