5 if ($ENV{'PERL_CORE'}){
7 unshift @INC, '../lib';
10 require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
13 if (! $Config{'useithreads'}) {
14 skip_all(q/Perl not compiled with 'useithreads'/);
18 use ExtUtils::testlib;
24 require threads::shared;
25 threads::shared->import();
27 if ($@ || ! $threads::shared::threads_shared) {
28 skip_all('threads::shared not available');
32 print("1..34\n"); ### Number of tests that will be run ###
35 print("ok 1 - Loaded\n");
37 ### Start of Testing ###
44 my $t = threads->create(\&content, "ok 2\n", "ok 3\n", 1..1000);
52 $t = threads->create(sub { lock($lock); print "ok 5\n"});
63 $ret = threads->create(\&dorecurse, @_);
68 my $t = threads->create(\&dorecurse, map { "ok $_\n" } 6..10);
73 # test that sleep lets other thread run
74 my $t = threads->create(\&dorecurse, "ok 11\n");
75 threads->yield; # help out non-preemptive thread implementations
88 $ret = threads->create(\&islocked, shift);
92 my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n");
100 my $same = sprintf( "%0.f", $testno);
101 return $testno eq $same;
105 my ($string, $string_end) = @_;
107 # Do the match, saving the output in appropriate variables
108 $string =~ /(.*)(is)(.*)/;
109 # Yield control, allowing the other thread to fill in the match variables
111 # Examine the match variable contents; on broken perls this fails
112 return $3 eq $string_end;
119 my $thr1 = threads->create(\&testsprintf, 15);
120 my $thr2 = threads->create(\&testsprintf, 16);
122 my $short = "This is a long string that goes on and on.";
123 my $shorte = " a long string that goes on and on.";
124 my $long = "This is short.";
125 my $longe = " short.";
126 my $foo = "This is bar bar bar.";
127 my $fooe = " bar bar bar.";
128 my $thr3 = new threads \&threaded, $short, $shorte;
129 my $thr4 = new threads \&threaded, $long, $longe;
130 my $thr5 = new threads \&testsprintf, 19;
131 my $thr6 = new threads \&testsprintf, 20;
132 my $thr7 = new threads \&threaded, $foo, $fooe;
143 # test that 'yield' is importable
157 my $th = async {return 1 };
162 # There is a miniscule chance this test case may falsely fail
163 # since it tests using rand()
166 threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
167 $_->join foreach threads->list;
168 ok((keys %rand >= 23), "Check that rand() is randomized in new threads");
173 run_perl(prog => 'use threads 1.71;' .
174 'sub a{threads->create(shift)} $t = a sub{};' .
175 '$t->tid; $t->join; $t->tid',
176 nolib => ($ENV{PERL_CORE}) ? 0 : 1,
177 switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
178 is($?, 0, 'coredump in global destruction');
180 # Attempt to free unreferenced scalar...
181 fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via scalar');
184 threads->create($test)->join();
188 # Attempt to free unreferenced scalar...
189 fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via $_[0]');
191 sub thr { threads->new($_[0]); }
196 # [perl #45053] Memory corruption from eval return in void context
197 fresh_perl_is(<<'EOI', 'ok', { }, 'void eval return');
199 threads->create(sub { eval '1' });
200 $_->join() for threads->list;
204 # test CLONE_SKIP() functionality
206 skip('CLONE_SKIP not implemented in Perl < 5.8.7', 5) if ($] < 5.008007);
214 sub CLONE_SKIP { $c{"A-$_[0]"}++; 1; }
215 sub DESTROY { $d{"A-". ref $_[0]}++ }
219 sub CLONE_SKIP { $c{"A1-$_[0]"}++; 1; }
220 sub DESTROY { $d{"A1-". ref $_[0]}++ }
228 sub CLONE_SKIP { $c{"B-$_[0]"}++; 0; }
229 sub DESTROY { $d{"B-" . ref $_[0]}++ }
233 sub CLONE_SKIP { $c{"B1-$_[0]"}++; 1; }
234 sub DESTROY { $d{"B1-" . ref $_[0]}++ }
242 sub CLONE_SKIP { $c{"C-$_[0]"}++; 1; }
243 sub DESTROY { $d{"C-" . ref $_[0]}++ }
247 sub CLONE_SKIP { $c{"C1-$_[0]"}++; 0; }
248 sub DESTROY { $d{"C1-" . ref $_[0]}++ }
256 sub DESTROY { $d{"D-" . ref $_[0]}++ }
265 for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) {
266 push @objs, bless [], $class;
271 my $cloned = ""; # XXX due to recursion, doesn't get initialized
272 $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs;
273 is($cloned, ($depth ? '00010001111' : '11111111111'),
274 "objs clone skip at depth $depth");
275 threads->create( \&f, $depth+1)->join if $depth < 2;
281 curr_test(curr_test()+2);
296 "counts of calls to CLONE_SKIP");
313 "counts of calls to DESTROY");