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