Move Thread::Semaphore from ext/ to dist/
[perl.git] / ext / threads / t / thread.t
1 use strict;
2 use warnings;
3
4 BEGIN {
5     require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
6
7     use Config;
8     if (! $Config{'useithreads'}) {
9         skip_all(q/Perl not compiled with 'useithreads'/);
10     }
11 }
12
13 use ExtUtils::testlib;
14
15 use threads;
16
17 BEGIN {
18     if (! eval 'use threads::shared; 1') {
19         skip_all('threads::shared not available');
20     }
21
22     $| = 1;
23     print("1..34\n");   ### Number of tests that will be run ###
24 };
25
26 print("ok 1 - Loaded\n");
27
28 ### Start of Testing ###
29
30 sub content {
31     print shift;
32     return shift;
33 }
34 {
35     my $t = threads->create(\&content, "ok 2\n", "ok 3\n", 1..1000);
36     print $t->join();
37 }
38 {
39     my $lock : shared;
40     my $t;
41     {
42         lock($lock);
43         $t = threads->create(sub { lock($lock); print "ok 5\n"});
44         print "ok 4\n";
45     }
46     $t->join();
47 }
48
49 sub dorecurse {
50     my $val = shift;
51     my $ret;
52     print $val;
53     if(@_) {
54         $ret = threads->create(\&dorecurse, @_);
55         $ret->join;
56     }
57 }
58 {
59     my $t = threads->create(\&dorecurse, map { "ok $_\n" } 6..10);
60     $t->join();
61 }
62
63 {
64     # test that sleep lets other thread run
65     my $t = threads->create(\&dorecurse, "ok 11\n");
66     threads->yield; # help out non-preemptive thread implementations
67     sleep 1;
68     print "ok 12\n";
69     $t->join();
70 }
71 {
72     my $lock : shared;
73     sub islocked {
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;
82     }
83 my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n");
84 $t->join->join;
85 }
86
87
88
89 sub testsprintf {
90     my $testno = shift;
91     my $same = sprintf( "%0.f", $testno);
92     return $testno eq $same;
93 }
94
95 sub threaded {
96     my ($string, $string_end) = @_;
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
103     return $3 eq $string_end;
104 }
105
106
107
108     curr_test(15);
109
110     my $thr1 = threads->create(\&testsprintf, 15);
111     my $thr2 = threads->create(\&testsprintf, 16);
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.";
119     my $thr3 = new threads \&threaded, $short, $shorte;
120     my $thr4 = new threads \&threaded, $long, $longe;
121     my $thr5 = new threads \&testsprintf, 19;
122     my $thr6 = new threads \&testsprintf, 20;
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());
132 }
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 }
152 {
153     # There is a miniscule chance this test case may falsely fail
154     # since it tests using rand()
155     my %rand : shared;
156     rand(10);
157     threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
158     $_->join foreach threads->list;
159     ok((keys %rand >= 23), "Check that rand() is randomized in new threads");
160 }
161
162 # bugid #24165
163
164 run_perl(prog => 'use threads 1.74;' .
165                  'sub a{threads->create(shift)} $t = a sub{};' .
166                  '$t->tid; $t->join; $t->tid',
167          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
168          switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
169 is($?, 0, 'coredump in global destruction');
170
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
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
195 # test CLONE_SKIP() functionality
196 SKIP: {
197     skip('CLONE_SKIP not implemented in Perl < 5.8.7', 5) if ($] < 5.008007);
198
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     {
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);
270     }
271
272     curr_test(curr_test()+2);
273     ok(eq_hash(\%c,
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");
288     ok(eq_hash(\%d,
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");
305 }
306
307 exit(0);
308
309 # EOF