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