dslinux/user/perl/ext/threads/t basic.t end.t join.t libc.t list.t problems.t stress_cv.t stress_re.t stress_string.t thread.t
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:27:03 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/threads/t
In directory antilope:/tmp/cvs-serv7729/ext/threads/t
Added Files:
basic.t end.t join.t libc.t list.t problems.t stress_cv.t
stress_re.t stress_string.t thread.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: end.t ---
# test that END blocks are run in the thread that created them and
# not in any child threads
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;
}
if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
print "1..0 # Skip: Devel::Peek was not built\n";
exit 0;
}
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..6\n" };
use threads;
use threads::shared;
my $test_id = 1;
share($test_id);
use Devel::Peek qw(Dump);
sub ok {
my ($ok, $name) = @_;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
$test_id++;
return $ok;
}
ok(1,'');
END { ok(1,"End block run once") }
threads->create(sub { eval "END { ok(1,'') }"})->join();
threads->create(sub { eval "END { ok(1,'') }"})->join();
threads->create(\&thread)->join();
sub thread {
eval "END { ok(1,'') }";
threads->create(sub { eval "END { ok(1,'') }"})->join();
}
--- NEW FILE: libc.t ---
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;
}
}
use ExtUtils::testlib;
use strict;
BEGIN { $| = 1; print "1..11\n"};
use threads;
use threads::shared;
my $i = 10;
my $y = 20000;
my %localtime;
for(0..$i) {
$localtime{$_} = localtime($_);
};
my $mutex = 1;
share($mutex);
sub localtime_r {
# print "Waiting for lock\n";
lock($mutex);
# print "foo\n";
my $retval = localtime(shift());
# unlock($mutex);
return $retval;
}
my @threads;
for(0..$i) {
my $thread = threads->create(sub {
my $arg = $_;
my $localtime = $localtime{$arg};
my $error = 0;
for(0..$y) {
my $lt = localtime($arg);
if($localtime ne $lt) {
$error++;
}
}
lock($mutex);
if($error) {
print "not ok $mutex # not a safe localtime\n";
} else {
print "ok $mutex\n";
}
$mutex++;
});
push @threads, $thread;
}
for(@threads) {
$_->join();
}
--- NEW FILE: stress_cv.t ---
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;
}
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..64\n" };
use threads;
print "ok 1\n";
sub ok {
my ($id, $ok, $name) = @_;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
ok(2,1,"");
my @threads;
for(3..33) {
ok($_,1,"Multiple thread test");
push @threads ,threads->create(sub { my $i = shift; for(1..500000) { $i++}},$_);
}
my $i = 34;
for(@threads) {
$_->join;
ok($i++,1,"Thread joined");
}
--- NEW FILE: list.t ---
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;
}
}
use ExtUtils::testlib;
use strict;
BEGIN { $| = 1; print "1..8\n" };
use threads;
print "ok 1\n";
#########################
sub ok {
my ($id, $ok, $name) = @_;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
ok(2, scalar @{[threads->list]} == 0,'');
threads->create(sub {})->join();
ok(3, scalar @{[threads->list]} == 0,'');
my $thread = threads->create(sub {});
ok(4, scalar @{[threads->list]} == 1,'');
$thread->join();
ok(5, scalar @{[threads->list]} == 0,'');
$thread = threads->create(sub { ok(6, threads->self == (threads->list)[0],'')});
threads->yield; # help out non-preemptive thread implementations
sleep 1;
ok(7, $thread == (threads->list)[0],'');
$thread->join();
ok(8, scalar @{[threads->list]} == 0,'');
--- NEW FILE: join.t ---
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;
}
if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
print "1..0 # Skip: Devel::Peek was not built\n";
exit 0;
}
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..14\n" };
use threads;
use threads::shared;
my $test_id = 1;
share($test_id);
use Devel::Peek qw(Dump);
sub ok {
my ($ok, $name) = @_;
lock $test_id; # make print and increment atomic
# You have to do it this way or VMS will get confused.
print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
$test_id++;
return $ok;
}
sub skip {
ok(1, "# Skipped: @_");
}
ok(1,"");
{
my $retval = threads->create(sub { return ("hi") })->join();
ok($retval eq 'hi', "Check basic returnvalue");
}
{
my ($thread) = threads->create(sub { return (1,2,3) });
my @retval = $thread->join();
ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
}
{
my $retval = threads->create(sub { return [1] })->join();
ok($retval->[0] == 1,"Check that a array ref works",);
}
{
my $retval = threads->create(sub { return { foo => "bar" }})->join();
ok($retval->{foo} eq 'bar',"Check that hash refs work");
}
{
my $retval = threads->create( sub {
open(my $fh, "+>threadtest") || die $!;
print $fh "test\n";
return $fh;
})->join();
ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
print $retval "test2\n";
# seek($retval,0,0);
# ok(<$retval> eq "test\n");
close($retval);
unlink("threadtest");
}
{
my $test = "hi";
my $retval = threads->create(sub { return $_[0]}, \$test)->join();
ok($$retval eq 'hi','');
}
{
my $test = "hi";
share($test);
my $retval = threads->create(sub { return $_[0]}, \$test)->join();
ok($$retval eq 'hi','');
$test = "foo";
ok($$retval eq 'foo','');
}
{
my %foo;
share(%foo);
threads->create(sub {
my $foo;
share($foo);
$foo = "thread1";
return $foo{bar} = \$foo;
})->join();
ok(1,"");
}
# We parse ps output so this is OS-dependent.
if ($^O eq 'linux') {
# First modify $0 in a subthread.
print "# mainthread: \$0 = $0\n";
threads->new( sub {
print "# subthread: \$0 = $0\n";
$0 = "foobar";
print "# subthread: \$0 = $0\n" } )->join;
print "# mainthread: \$0 = $0\n";
print "# pid = $$\n";
if (open PS, "ps -f |") { # Note: must work in (all) systems.
my ($sawpid, $sawexe);
while (<PS>) {
chomp;
print "# [$_]\n";
if (/^\S+\s+$$\s/) {
$sawpid++;
if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
$sawexe++;
}
last;
}
}
close PS or die;
if ($sawpid) {
ok($sawpid && $sawexe, 'altering $0 is effective');
} else {
skip("\$0 check: did not see pid $$ in 'ps -f |'");
}
} else {
skip("\$0 check: opening 'ps -f |' failed: $!");
}
} else {
skip("\$0 check: only on Linux");
}
{
my $t = threads->new(sub {});
$t->join;
my $x = threads->new(sub {});
$x->join;
eval {
$t->join;
};
my $ok = 0;
$ok++ if($@ =~/Thread already joined/);
ok($ok, "Double join works");
}
{
# The "use IO" is not actually used for anything; its only purpose is to
# incite a lot of calls to newCONSTSUB. See the p5p archives for
# the thread "maint at 20974 or before broke mp2 ithreads test".
use IO;
# this coredumped between #20930 and #21000
$_->join for map threads->new(sub{ok($_, "stress newCONSTSUB")}), 1..2;
}
--- NEW FILE: stress_string.t ---
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;
}
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..64\n" };
use threads;
print "ok 1\n";
sub ok {
my ($id, $ok, $name) = @_;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
ok(2,1,"");
sub test9 {
my $i = shift;
for(1..500000) { $i++};
}
my @threads;
for(3..33) {
ok($_,1,"Multiple thread test");
push @threads ,threads->create('test9',$_);
}
my $i = 34;
for(@threads) {
$_->join;
ok($i++,1,"Thread joined");
}
--- NEW FILE: thread.t ---
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");
}
--- NEW FILE: problems.t ---
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;
}
}
use warnings;
use strict;
use threads;
use threads::shared;
use Hash::Util 'lock_keys';
# Note that we can't use Test::More here, as we would need to
# call is() from within the DESTROY() function at global destruction time,
# and parts of Test::* may have already been freed by then
print "1..14\n";
my $test : shared = 1;
sub is($$$) {
my ($got, $want, $desc) = @_;
unless ($got eq $want) {
print "# EXPECTED: $want\n";
print "# GOT: $got\n";
print "not ";
}
print "ok $test - $desc\n";
$test++;
}
#
# This tests for too much destruction
# which was caused by cloning stashes
# on join which led to double the dataspace
#
#########################
$|++;
{
sub Foo::DESTROY {
my $self = shift;
my ($package, $file, $line) = caller;
is(threads->tid(),$self->{tid},
"In destroy[$self->{tid}] it should be correct too" )
}
my $foo;
$foo = bless {tid => 0}, 'Foo';
my $bar = threads->create(sub {
is(threads->tid(),1, "And tid be 1 here");
$foo->{tid} = 1;
return $foo;
})->join();
$bar->{tid} = 0;
}
#
# This tests whether we can call Config::myconfig after threads have been
# started (interpreter cloned). 5.8.1 and 5.8.2 contained a bug that would
# disallow that too be done, because an attempt was made to change a variable
# with the : unique attribute.
#
#########################
threads->new( sub {1} )->join;
my $not = eval { Config::myconfig() } ? '' : 'not ';
print "${not}ok $test - Are we able to call Config::myconfig after clone\n";
$test++;
# bugid 24383 - :unique hashes weren't being made readonly on interpreter
# clone; check that they are.
our $unique_scalar : unique;
our @unique_array : unique;
our %unique_hash : unique;
threads->new(
sub {
my $TODO = ":unique needs to be re-implemented in a non-broken way";
eval { $unique_scalar = 1 };
print $@ =~ /read-only/
? '' : 'not ', "ok $test # TODO $TODO unique_scalar\n";
$test++;
eval { $unique_array[0] = 1 };
print $@ =~ /read-only/
? '' : 'not ', "ok $test # TODO $TODO - unique_array\n";
$test++;
eval { $unique_hash{abc} = 1 };
print $@ =~ /disallowed/
? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
$test++;
}
)->join;
# bugid #24940 :unique should fail on my and sub declarations
for my $decl ('my $x : unique', 'sub foo : unique') {
eval $decl;
print $@ =~
/^The 'unique' attribute may only be applied to 'our' variables/
? '' : 'not ', "ok $test - $decl\n";
$test++;
}
# Returing a closure from a thread caused problems. If the last index in
# the anon sub's pad wasn't for a lexical, then a core dump could occur.
# Otherwise, there might be leaked scalars.
# XXX DAPM 9-Jan-04 - backed this out for now - returning a closure from a
# thread seems to crash win32
# sub f {
# my $x = "foo";
# sub { $x."bar" };
# }
#
# my $string = threads->new(\&f)->join->();
# print $string eq 'foobar' ? '' : 'not ', "ok $test - returning closure\n";
# $test++;
# Nothing is checking that total keys gets cloned correctly.
my %h = (1,2,3,4);
is (keys %h, 2, "keys correct in parent");
my $child = threads->new(sub { return scalar keys %h })->join;
is ($child, 2, "keys correct in child");
lock_keys (%h);
delete $h{1};
is (keys %h, 1, "keys correct in parent with restricted hash");
$child = threads->new(sub { return scalar keys %h })->join;
is ($child, 1, "keys correct in child with restricted hash");
1;
--- NEW FILE: stress_re.t ---
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;
}
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..64\n" };
use threads;
print "ok 1\n";
sub ok {
my ($id, $ok, $name) = @_;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
ok(2,1,"");
sub test9 {
my $s = "abcd" x (1000 + $_[0]);
my $t = '';
while ($s =~ /(.)/g) { $t .= $1 }
print "not ok $_[0]\n" if $s ne $t;
}
my @threads;
for(3..33) {
ok($_,1,"Multiple thread test");
push @threads ,threads->create('test9',$_);
}
my $i = 34;
for(@threads) {
$_->join;
ok($i++,1,"Thread joined");
}
--- NEW FILE: basic.t ---
#
# The reason this does not use a Test module is that
# they mess up test numbers between threads
#
# And even when that will be fixed, this is a basic
# test and should not rely on shared variables
#
# This will test the basic API, it will not use any coderefs
# as they are more advanced
#
#########################
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;
}
}
use ExtUtils::testlib;
use strict;
BEGIN { $| = 1; print "1..19\n" };
use threads;
print "ok 1\n";
#########################
sub ok {
my ($id, $ok, $name) = @_;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
sub test1 {
ok(2,'bar' eq $_[0],"Test that argument passing works");
}
threads->create('test1','bar')->join();
sub test2 {
ok(3,'bar' eq $_[0]->[0]->{foo},"Test that passing arguments as references work");
}
threads->create('test2',[{foo => 'bar'}])->join();
#test execuion of normal sub
sub test3 { ok(4,shift() == 1,"Test a normal sub") }
threads->create('test3',1)->join();
#check Config
ok(5, 1 == $threads::threads,"Check that threads::threads is true");
#test trying to detach thread
sub test4 { ok(6,1,"Detach test") }
my $thread1 = threads->create('test4');
$thread1->detach();
threads->yield; # help out non-preemptive thread implementations
sleep 2;
ok(7,1,"Detach test");
sub test5 {
threads->create('test6')->join();
ok(9,1,"Nested thread test");
}
sub test6 {
ok(8,1,"Nested thread test");
}
threads->create('test5')->join();
sub test7 {
my $self = threads->self();
ok(10, $self->tid == 7, "Wanted 7, got ".$self->tid);
ok(11, threads->tid() == 7, "Wanted 7, got ".threads->tid());
}
threads->create('test7')->join;
sub test8 {
my $self = threads->self();
ok(12, $self->tid == 8, "Wanted 8, got ".$self->tid);
ok(13, threads->tid() == 8, "Wanted 8, got ".threads->tid());
}
threads->create('test8')->join;
#check support for threads->self() in main thread
ok(14, 0 == threads->self->tid(),"Check so that tid for threads work for main thread");
ok(15, 0 == threads->tid(),"Check so that tid for threads work for main thread");
{
no warnings;
local *CLONE = sub { ok(16, threads->tid() == 9, "Tid should be correct in the clone")};
threads->create(sub { ok(17, threads->tid() == 9, "And tid be 9 here too") })->join();
}
{
sub Foo::DESTROY {
ok(19, threads->tid() == 10, "In destroy it should be correct too" )
}
my $foo;
threads->create(sub { ok(18, threads->tid() == 10, "And tid be 10 here");
$foo = bless {}, 'Foo';
return undef;
})->join();
}
1;
More information about the dslinux-commit
mailing list