BEGIN {
chdir 't' if -d 't';
push @INC, '../lib','.';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
require "test.pl";
}
use ExtUtils::testlib;
use strict;
BEGIN { $| = 1; print "1..31\n" };
use threads;
use threads::shared;
print "ok 1\n";
sub content {
print shift;
return shift;
}
{
my $t = threads->new(\&content, "ok 2\n", "ok 3\n", 1..1000);
print $t->join();
}
{
my $lock : shared;
my $t;
{
lock($lock);
$t = threads->new(sub { lock($lock); print "ok 5\n"});
print "ok 4\n";
}
$t->join();
}
sub dorecurse {
my $val = shift;
my $ret;
print $val;
if(@_) {
$ret = threads->new(\&dorecurse, @_);
$ret->join;
}
}
{
my $t = threads->new(\&dorecurse, map { "ok $_\n" } 6..10);
$t->join();
}
{
# test that sleep lets other thread run
my $t = threads->new(\&dorecurse, "ok 11\n");
threads->yield; # help out non-preemptive thread implementations
sleep 1;
print "ok 12\n";
$t->join();
}
{
my $lock : shared;
sub islocked {
lock($lock);
my $val = shift;
my $ret;
print $val;
if (@_) {
$ret = threads->new(\&islocked, shift);
}
return $ret;
}
my $t = threads->new(\&islocked, "ok 13\n", "ok 14\n");
$t->join->join;
}
sub testsprintf {
my $testno = shift;
my $same = sprintf( "%0.f", $testno);
return $testno eq $same;
}
sub threaded {
my ($string, $string_end) = @_;
# Do the match, saving the output in appropriate variables
$string =~ /(.*)(is)(.*)/;
# Yield control, allowing the other thread to fill in the match variables
threads->yield();
# Examine the match variable contents; on broken perls this fails
return $3 eq $string_end;
}
{
curr_test(15);
my $thr1 = threads->new(\&testsprintf, 15);
my $thr2 = threads->new(\&testsprintf, 16);
my $short = "This is a long string that goes on and on.";
my $shorte = " a long string that goes on and on.";
my $long = "This is short.";
my $longe = " short.";
my $foo = "This is bar bar bar.";
my $fooe = " bar bar bar.";
my $thr3 = new threads \&threaded, $short, $shorte;
my $thr4 = new threads \&threaded, $long, $longe;
my $thr5 = new threads \&testsprintf, 19;
my $thr6 = new threads \&testsprintf, 20;
my $thr7 = new threads \&threaded, $foo, $fooe;
ok($thr1->join());
ok($thr2->join());
ok($thr3->join());
ok($thr4->join());
ok($thr5->join());
ok($thr6->join());
ok($thr7->join());
}
# test that 'yield' is importable
package Test1;
use threads 'yield';
yield;
main::ok(1);
package main;
# test async
{
my $th = async {return 1 };
ok($th);
ok($th->join());
}
{
# there is a little chance this test case will falsly fail
# since it tests rand
my %rand : shared;
rand(10);
threads->new( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
$_->join foreach threads->list;
# use Data::Dumper qw(Dumper);
# print Dumper(\%rand);
#$val = rand();
ok((keys %rand == 25), "Check that rand works after a new thread");
}
# bugid #24165
run_perl(prog =>
'use threads; sub a{threads->new(shift)} $t = a sub{}; $t->tid; $t->join; $t->tid');
is($?, 0, 'coredump in global destruction');
# test CLONE_SKIP() functionality
{
my %c : shared;
my %d : shared;
# ---
package A;
sub CLONE_SKIP { $c{"A-$_[0]"}++; 1; }
sub DESTROY { $d{"A-". ref $_[0]}++ }
package A1;
our @ISA = qw(A);
sub CLONE_SKIP { $c{"A1-$_[0]"}++; 1; }
sub DESTROY { $d{"A1-". ref $_[0]}++ }
package A2;
our @ISA = qw(A1);
# ---
package B;
sub CLONE_SKIP { $c{"B-$_[0]"}++; 0; }
sub DESTROY { $d{"B-" . ref $_[0]}++ }
package B1;
our @ISA = qw(B);
sub CLONE_SKIP { $c{"B1-$_[0]"}++; 1; }
sub DESTROY { $d{"B1-" . ref $_[0]}++ }
package B2;
our @ISA = qw(B1);
# ---
package C;
sub CLONE_SKIP { $c{"C-$_[0]"}++; 1; }
sub DESTROY { $d{"C-" . ref $_[0]}++ }
package C1;
our @ISA = qw(C);
sub CLONE_SKIP { $c{"C1-$_[0]"}++; 0; }
sub DESTROY { $d{"C1-" . ref $_[0]}++ }
package C2;
our @ISA = qw(C1);
# ---
package D;
sub DESTROY { $d{"D-" . ref $_[0]}++ }
package D1;
our @ISA = qw(D);
package main;
{
my @objs;
for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) {
push @objs, bless [], $class;
}
sub f {
my $depth = shift;
my $cloned = ""; # XXX due to recursion, doesn't get initialized
$cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs;
is($cloned, ($depth ? '00010001111' : '11111111111'),
"objs clone skip at depth $depth");
threads->new( \&f, $depth+1)->join if $depth < 2;
@objs = ();
}
f(0);
}
curr_test(curr_test()+2);
ok(eq_hash(\%c,
{
qw(
A-A 2
A1-A1 2
A1-A2 2
B-B 2
B1-B1 2
B1-B2 2
C-C 2
C1-C1 2
C1-C2 2
)
}),
"counts of calls to CLONE_SKIP");
ok(eq_hash(\%d,
{
qw(
A-A 1
A1-A1 1
A1-A2 1
B-B 3
B1-B1 1
B1-B2 1
C-C 1
C1-C1 3
C1-C2 3
D-D 3
D-D1 3
)
}),
"counts of calls to DESTROY");
}