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