develooper Front page | perl.perl5.porters | Postings from March 2006

[PATCH] Upgrade to threads 1.12

Thread Next
From:
Jerry D. Hedden
Date:
March 19, 2006 16:01
Subject:
[PATCH] Upgrade to threads 1.12
Message ID:
20060319170055.fb30e530d17747c2b054d625b8945d88.7ae3a66176.wbe@email.email.secureserver.net
diff -ur perl-current/ext/threads/Changes perl-threads/ext/threads/Changes
--- perl-current/ext/threads/Changes	2001-09-18 11:18:50.000000000 -0400
+++ perl-threads/ext/threads/Changes	2006-03-19 17:34:49.000000000 -0500
@@ -1,5 +1,28 @@
 Revision history for Perl extension threads.
 
+1.12 Sun Mar 19 17:34:49 EST 2006
+	- Implemented $thr1->equal($thr2) in XS
+	- Use $ENV{PERL_CORE} in tests
+
+1.11 Fri Mar 17 13:24:35 EST 2006
+	- Fix for freeing thread's Perl interpreter
+	- Removed BUGS POD item regarding returning objects from threads
+	- Enabled closure return test in t/problems.t
+	- Handle deprecation of :unique in tests
+	- XS code cleanup
+	- Better POD coverage
+
+1.09 Mon Mar 13 14:14:37 EST 2006
+	- Initial (re-)release to CPAN
+	- 64-bit TIDs
+	- API for thread stack size (courtesy of Dean Arnold)
+	- Made threads->list() context sensitive
+	- Implemented threads->object($tid) in XS
+	- Added $thr->_handle() method
+
+
+Ancient history:
+
 0.03  Mon Jul  2 12:00:50 CEST 2001
 	Fixed bug with threads->self() in main thread, thanks Hackworth!
 
diff -ur perl-current/ext/threads/Makefile.PL perl-threads/ext/threads/Makefile.PL
--- perl-current/ext/threads/Makefile.PL	2003-04-03 01:11:50.000000000 -0500
+++ perl-threads/ext/threads/Makefile.PL	2006-03-10 16:47:15.000000000 -0500
@@ -1,28 +1,44 @@
+# Module makefile for threads (using ExtUtils::MakeMaker)
+
+require 5.008;
+
+use strict;
+use warnings;
+
 use ExtUtils::MakeMaker;
-# See lib/ExtUtils/MakeMaker.pm for details of how to influence
-# the contents of the Makefile that is written.
 
 WriteMakefile(
-    'NAME'		=> 'threads',
-    'VERSION_FROM'	=> 'threads.pm', # finds $VERSION
-    'PREREQ_PM'		=> {}, # e.g., Module::Name => 1.1
-    ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
-      (ABSTRACT_FROM => 'threads.pm', # retrieve abstract from module
-       AUTHOR     => 'Artur Bergman  <artur@contiller.se>') : ()),
-    'MAN3PODS'		=> {},  # Pods will be built by installman
-    'LIBS'		=> [''], # e.g., '-lm'
-    'DEFINE'		=> '', # e.g., '-DHAVE_SOMETHING'
-	# Insert -I. if you add *.h files later:
-#    'INC'		=> '', # e.g., '-I/usr/include/other'
-	# Un-comment this if you add C files to link with later:
-    # 'OBJECT'		=> '$(O_FILES)', # link all the C files too
-
-    # ext/threads/shared is a completely different module.  Don't
-    # recurse into it.
-    'NORECURS'          => 1,
-
-    # Bug in MakeMaker continues to put ext/threads/shared into DIR
-    # even if we said NORECURS.  Remove when fixed.
-    'DIR'               => [],
+    'NAME'              => 'threads',
+    'AUTHOR'            => 'Artur Bergman <sky AT crucially DOT net>',
+    'VERSION_FROM'      => 'threads.pm',
+    'ABSTRACT_FROM'     => 'threads.pm',
+    'PM' => {
+        'threads.pm'    => '$(INST_LIBDIR)/threads.pm',
+    },
+    'PREREQ_PM'         => {
+        'threads::shared' => 0,
+        'XSLoader'        => 0,
+    },
+    'INSTALLDIRS'       => 'perl',
+    ((ExtUtils::MakeMaker->VERSION() lt '6.25') ?
+        ('PL_FILES' => { })            : ()),
+    ((ExtUtils::MakeMaker->VERSION() gt '6.30') ?
+        ('LICENSE'  => 'perl')         : ()),
 );
 
+
+# Add additional target(s) to Makefile for use by module maintainer
+sub MY::postamble
+{
+    return <<'_EXTRAS_';
+ppport:
+	@( cd /tmp; perl -e 'use Devel::PPPort; Devel::PPPort::WriteFile("ppport.h");' )
+	@if ! cmp -s ppport.h /tmp/ppport.h; then \
+	    diff ppport.h /tmp/ppport.h ; \
+	    echo; \
+	    perl /tmp/ppport.h; \
+	fi
+_EXTRAS_
+}
+
+# EOF
diff -ur perl-current/ext/threads/README perl-threads/ext/threads/README
--- perl-current/ext/threads/README	2001-09-18 11:18:50.000000000 -0400
+++ perl-threads/ext/threads/README	2006-03-17 13:25:17.000000000 -0500
@@ -1,8 +1,8 @@
-threads version 0.03
+threads version 1.12
 ====================
 
-This module needs perl 5.7.2 or later compiled with USEITHREADS, 
-it exposes interpreter threads to the perl level.
+This module needs perl 5.8.0 or later compiled with 'useithreads'.
+It exposes interpreter threads to the Perl level.
 
 INSTALLATION
 
@@ -17,8 +17,13 @@
 
 This module requires these other modules and libraries:
 
+    threads::shared
 
 COPYRIGHT AND LICENCE
 
-Copyright (C) 2001 Artur Bergman artur at contiller.se
-Same licence as perl.
+Copyright (C) 2001 Artur Bergman <sky AT crucially DOT net>
+Same licence as Perl.
+
+CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org>
+
+# EOF
diff -ur perl-current/ext/threads/t/basic.t perl-threads/ext/threads/t/basic.t
--- perl-current/ext/threads/t/basic.t	2003-06-07 10:24:21.000000000 -0400
+++ perl-threads/ext/threads/t/basic.t	2006-03-18 15:49:19.000000000 -0500
@@ -1,144 +1,160 @@
-
-
-#
-# 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
-#
-#########################
-
+use strict;
+use warnings;
 
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
     }
 }
 
 use ExtUtils::testlib;
-use strict;
-BEGIN { $| = 1; print "1..19\n" };
-use threads;
-
-
-
-print "ok 1\n";
 
-
-#########################
-
-
-
-
-sub ok {	
+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;
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
 
-    return $ok;
+    return ($ok);
 }
 
+BEGIN {
+    $| = 1;
+    print("1..30\n");   ### Number of tests that will be run ###
+};
 
+use threads;
 
-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");
+if ($threads::VERSION && ! exists($ENV{'PERL_CORE'})) {
+    print(STDERR "# Testing threads $threads::VERSION\n");
 }
 
-threads->create('test2',[{foo => 'bar'}])->join();
+ok(1, 1, 'Loaded');
 
+### Start of Testing ###
 
-#test execuion of normal sub
-sub test3 { ok(4,shift() == 1,"Test a normal sub") }
-threads->create('test3',1)->join();
+ok(2, 1 == $threads::threads, "Check that threads::threads is true");
 
+sub test1 {
+    ok(3,'bar' eq $_[0], "Test that argument passing works");
+}
+threads->create('test1', 'bar')->join();
 
-#check Config
-ok(5, 1 == $threads::threads,"Check that threads::threads is true");
+sub test2 {
+    ok(4,'bar' eq $_[0]->[0]->{'foo'}, "Test that passing arguments as references work");
+}
+threads->create(\&test2, [{'foo' => 'bar'}])->join();
 
-#test trying to detach thread
+sub test3 {
+    ok(5, shift() == 1, "Test a normal sub");
+}
+threads->create(\&test3, 1)->join();
 
-sub test4 { ok(6,1,"Detach test") }
 
-my $thread1 = threads->create('test4');
+sub test4 {
+    ok(6, 1, "Detach test");
+}
+{
+    my $thread1 = threads->create('test4');
+    $thread1->detach();
+}
 
-$thread1->detach();
 threads->yield; # help out non-preemptive thread implementations
 sleep 2;
-ok(7,1,"Detach test");
 
+ok(7, 1, "Detach test");
 
 
 sub test5 {
-	threads->create('test6')->join();
-	ok(9,1,"Nested thread test");
+    threads->create('test6')->join();
+    ok(9, 1, "Nested thread test");
 }
 
 sub test6 {
-	ok(8,1,"Nested thread test");
+    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());
+    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());
+    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");
+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();
+    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" )
-	}
+{
+    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();
-
+    threads->create(sub {
+        ok(18, threads->tid() == 10, "And tid be 10 here");
+        $foo = bless {}, 'Foo';
+        return undef;
+    })->join();
 }
-1;
 
 
+my $thr1 = threads->create(sub {});
+my $thr2 = threads->create(sub {});
+my $thr3 = threads->object($thr1->tid());
+
+ok(20, $thr1 != $thr2,   'Treads not equal');
+ok(21, $thr1 == $thr3,   'Threads equal');
+
+ok(22, $thr1->_handle(), 'Handle method');
+ok(23, $thr2->_handle(), 'Handle method');
 
+ok(24, threads->object($thr1->tid())->tid() == 11, 'Object method');
+ok(25, threads->object($thr2->tid())->tid() == 12, 'Object method');
 
+$thr1->join();
+$thr2->join();
 
+my $sub = sub { ok(26, shift() == 1, "Test code ref"); };
+threads->create($sub, 1)->join();
 
+my $thrx = threads->object(99);
+ok(27, ! defined($thrx), 'No object');
+$thrx = threads->object();
+ok(28, ! defined($thrx), 'No object');
+$thrx = threads->object(undef);
+ok(29, ! defined($thrx), 'No object');
+$thrx = threads->object(0);
+ok(30, ! defined($thrx), 'No object');
 
+# EOF
diff -ur perl-current/ext/threads/t/end.t perl-threads/ext/threads/t/end.t
--- perl-current/ext/threads/t/end.t	2004-10-31 07:47:03.000000000 -0500
+++ perl-threads/ext/threads/t/end.t	2006-03-18 15:50:03.000000000 -0500
@@ -1,48 +1,62 @@
-
-# test that END blocks are run in the thread that created them and
-# not in any child threads
+use strict;
+use warnings;
 
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
     }
-    if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
-	print "1..0 # Skip: Devel::Peek was not built\n";
-	exit 0;
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
     }
 }
 
 use ExtUtils::testlib;
-use strict;
-BEGIN { print "1..6\n" };
+
+sub ok {
+    my ($id, $ok, $name) = @_;
+
+    # You have to do it this way or VMS will get confused.
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
+
+    return ($ok);
+}
+
+BEGIN {
+    $| = 1;
+    print("1..6\n");   ### Number of tests that will be run ###
+};
+
 use threads;
 use threads::shared;
+ok(1, 1, 'Loaded');
+
+### Start of Testing ###
+
+# Test that END blocks are run in the thread that created them,
+# and not in any child threads.
 
 my $test_id = 1;
 share($test_id);
-use Devel::Peek qw(Dump);
 
-sub ok {
-    my ($ok, $name) = @_;
+END {
+    ok(++$test_id, 1, 'Main END block')
+}
 
-    # 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";
+threads->create(sub { eval "END { ok(++\$test_id, 1, '1st thread END block') }"})->join();
+threads->create(sub { eval "END { ok(++\$test_id, 1, '2nd thread END block') }"})->join();
 
-    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
-    $test_id++;
-    return $ok;
+sub thread {
+    eval "END { ok(++\$test_id, 1, '4th thread END block') }";
+    threads->create(sub { eval "END { ok(++\$test_id, 1, '5th thread END block') }"})->join();
 }
-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();
-}
+# EOF
diff -ur perl-current/ext/threads/t/join.t perl-threads/ext/threads/t/join.t
--- perl-current/ext/threads/t/join.t	2005-05-12 15:37:24.000000000 -0400
+++ perl-threads/ext/threads/t/join.t	2006-03-18 15:50:34.000000000 -0500
@@ -1,136 +1,140 @@
+use strict;
+use warnings;
+
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
     }
-    if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
-	print "1..0 # Skip: Devel::Peek was not built\n";
-	exit 0;
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\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
+    my ($id, $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";
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
 
-    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
-    $test_id++;
-    return $ok;
+    return ($ok);
 }
 
 sub skip {
-    ok(1, "# Skipped: @_");
+    my $id = shift;
+    ok(shift, 1, "# Skipped: @_");
 }
 
-ok(1,"");
+BEGIN {
+    $| = 1;
+    print("1..14\n");   ### Number of tests that will be run ###
+};
+
+use threads;
+use threads::shared;
+ok(1, 1, 'Loaded');
+
+### Start of Testing ###
 
+my $test_id = 1;
+share($test_id);
 
 {
     my $retval = threads->create(sub { return ("hi") })->join();
-    ok($retval eq 'hi', "Check basic returnvalue");
+    ok(++$test_id, $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,'');
+    ok(++$test_id, $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",);
+    ok(++$test_id, $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");
+    ok(++$test_id, $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;
+        open(my $fh, "+>threadtest") || die $!;
+        print $fh "test\n";
+        return $fh;
     })->join();
-    ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
+    ok(++$test_id, 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','');
+    ok(++$test_id, $$retval eq 'hi','');
 }
 {
     my $test = "hi";
     share($test);
     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
-    ok($$retval eq 'hi','');
+    ok(++$test_id, $$retval eq 'hi','');
     $test = "foo";
-    ok($$retval eq 'foo','');
+    ok(++$test_id, $$retval eq 'foo','');
 }
 {
     my %foo;
     share(%foo);
     threads->create(sub { 
-	my $foo;
-	share($foo);
-	$foo = "thread1";
-	return $foo{bar} = \$foo;
+        my $foo;
+        share($foo);
+        $foo = "thread1";
+        return $foo{bar} = \$foo;
     })->join();
-    ok(1,"");
+    ok(++$test_id, 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++;
+    # 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+$$\s/) {
+                $sawpid++;
+                if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
+                    $sawexe++;
+                }
+                last;
+            }
+        }
+        close PS or die;
+        if ($sawpid) {
+            ok(++$test_id, $sawpid && $sawexe, 'altering $0 is effective');
+        } else {
+            skip(++$test_id, "\$0 check: did not see pid $$ in 'ps -f |'");
         }
-	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 |'");
+        skip(++$test_id,"\$0 check: opening 'ps -f |' failed: $!");
     }
-  } else {
-    skip("\$0 check: opening 'ps -f |' failed: $!");
-  }
 } else {
-  skip("\$0 check: only on Linux");
+    skip(++$test_id,"\$0 check: only on Linux");
 }
 
 {
@@ -138,20 +142,18 @@
     $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");
+    eval { $t->join; };
+    ok(++$test_id, ($@ =~ /Thread already joined/), "Double join works");
 }
 
 {
-    # The "use IO::File" 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@20974 or before broke mp2 ithreads test".
-    use IO::File;
-    # this coredumped between #20930 and #21000
-    $_->join for map threads->new(sub{ok($_, "stress newCONSTSUB")}), 1..2;
+    no warnings 'deprecated';
+
+    # 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@20974 or before broke mp2 ithreads test".
+    use IO;
+    $_->join for map threads->new(sub{ok(++$test_id, $_, "stress newCONSTSUB")}), 1..2;
 }
 
+# EOF
diff -ur perl-current/ext/threads/t/libc.t perl-threads/ext/threads/t/libc.t
--- perl-current/ext/threads/t/libc.t	2003-06-07 09:59:14.000000000 -0400
+++ perl-threads/ext/threads/t/libc.t	2006-03-18 15:50:35.000000000 -0500
@@ -1,60 +1,83 @@
+use strict;
+use warnings;
 
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
     }
 }
 
 use ExtUtils::testlib;
-use strict;
-BEGIN { $| = 1; print "1..11\n"};
+
+sub ok {
+    my ($id, $ok, $name) = @_;
+
+    # You have to do it this way or VMS will get confused.
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
+
+    return ($ok);
+}
+
+BEGIN {
+    $| = 1;
+    print("1..12\n");   ### Number of tests that will be run ###
+};
 
 use threads;
 use threads::shared;
+ok(1, 1, 'Loaded');
+
+### Start of Testing ###
+
 my $i = 10;
 my $y = 20000;
+
 my %localtime;
-for(0..$i) {
-	$localtime{$_} = localtime($_);
+for (0..$i) {
+    $localtime{$_} = localtime($_);
 };
-my $mutex = 1;
+
+my $mutex = 2;
 share($mutex);
+
 sub localtime_r {
-#  print "Waiting for lock\n";
-  lock($mutex);
-#  print "foo\n";
-  my $retval = localtime(shift());
-#  unlock($mutex);
-  return $retval;
+    lock($mutex);
+    my $retval = localtime(shift());
+    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 (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);
+                    ok($mutex, ! $error, 'localtime safe');
+                    $mutex++;
+                  });
+    push @threads, $thread;
 }
 
-for(@threads) {
-  $_->join();
+for (@threads) {
+    $_->join();
 }
 
+# EOF
diff -ur perl-current/ext/threads/t/list.t perl-threads/ext/threads/t/list.t
--- perl-current/ext/threads/t/list.t	2003-06-07 10:24:21.000000000 -0400
+++ perl-threads/ext/threads/t/list.t	2006-03-18 15:50:36.000000000 -0500
@@ -1,54 +1,72 @@
+use strict;
+use warnings;
 
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
     }
 }
 
 use ExtUtils::testlib;
 
-use strict;
-
-
-BEGIN { $| = 1; print "1..8\n" };
-use threads;
-
-
-
-print "ok 1\n";
-
-
-#########################
-sub ok {	
+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;
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
 
-    return $ok;
+    return ($ok);
 }
 
-ok(2, scalar @{[threads->list]} == 0,'');
+BEGIN {
+    $| = 1;
+    print("1..15\n");   ### Number of tests that will be run ###
+};
 
+use threads;
+ok(1, 1, 'Loaded');
 
+### Start of Testing ###
+
+ok(2, scalar @{[threads->list()]} == 0, 'No threads yet');
 
 threads->create(sub {})->join();
-ok(3, scalar @{[threads->list]} == 0,'');
+ok(3, scalar @{[threads->list()]} == 0, 'Empty thread list after join');
 
 my $thread = threads->create(sub {});
-ok(4, scalar @{[threads->list]} == 1,'');
+ok(4, scalar(threads->list()) == 1, 'Non-empty thread list');
+ok(5, threads->list() == 1,             'Non-empty thread list');
 $thread->join();
-ok(5, scalar @{[threads->list]} == 0,'');
+ok(6, scalar @{[threads->list()]} == 0, 'Thread list empty again');
+ok(7, threads->list() == 0,             'Thread list empty again');
+
+$thread = threads->create(sub {
+    ok(8, threads->list() == 1, 'Non-empty thread list in thread');
+    ok(9, threads->self == (threads->list())[0], 'Self in thread list')
+});
 
-$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],'');
+
+ok(10, scalar(threads->list()) == 1, 'Thread count 1');
+ok(11, threads->list() == 1,             'Thread count 1');
+my $cnt = threads->list();
+ok(12, $cnt == 1,                        'Thread count 1');
+my ($thr_x) = threads->list();
+ok(13, $thread == $thr_x,                'Thread in list');
 $thread->join();
-ok(8, scalar @{[threads->list]} == 0,'');
+ok(14, scalar @{[threads->list()]} == 0, 'Thread list empty');
+ok(15, threads->list() == 0,             'Thread list empty');
+
+# EOF
diff -ur perl-current/ext/threads/t/problems.t perl-threads/ext/threads/t/problems.t
--- perl-current/ext/threads/t/problems.t	2006-03-16 03:34:17.000000000 -0500
+++ perl-threads/ext/threads/t/problems.t	2006-03-18 15:50:37.000000000 -0500
@@ -1,111 +1,129 @@
+use strict;
+use warnings;
 
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
     }
 }
 
-use warnings;
-no warnings 'deprecated';
-use strict;
+use ExtUtils::testlib;
+
+BEGIN {
+    $| = 1;
+    if ($] == 5.008) {
+        print("1..15\n");   ### Number of tests that will be run ###
+    } else {
+        print("1..16\n");   ### Number of tests that will be run ###
+    }
+};
+
 use threads;
 use threads::shared;
-use Hash::Util 'lock_keys';
+print("ok 1 - Loaded\n");
+
+### Start of Testing ###
 
-# 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
+no warnings 'deprecated';       # Suppress warnings related to :unique
 
-print "1..14\n";
+use Hash::Util 'lock_keys';
 
-my $test : shared = 1;
+my $test :shared = 2;
 
-sub is($$$) {
+sub is($$$)
+{
     my ($got, $want, $desc) = @_;
-    unless ($got eq $want) {
-	print "# EXPECTED: $want\n";
-	print "# GOT:      $got\n";
-	print "not ";
+    if ($got ne $want) {
+        print("# EXPECTED: $want\n");
+        print("# GOT:      $got\n");
+        print("not ");
     }
-    print "ok $test - $desc\n";
+    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;
+{
+    # 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;
+        if (defined($self->{tid})) {
+            is(threads->tid(),$self->{tid},
+                    "In destroy[$self->{tid}] it should be correct too" )
+        }
+    }
+
+    my $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";
+# disallow that to be done because an attempt was made to change a variable
+# with the :unique attribute.
+
+if ($] == 5.008 || $] >= 5.008003) {
+    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";
+} else {
+    print "ok $test # Skip 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;
+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++;
+        if ($] >= 5.008003 && $^O ne 'MSWin32') {
+            eval { $unique_hash{abc} = 1 };
+            print $@ =~ /disallowed/
+              ? '' : 'not ', "ok $test # TODO $TODO - unique_hash\n";
+        } else {
+            print("ok $test # Skip $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";
+    if ($] >= 5.008005) {
+        eval $decl;
+        print $@ =~ /^The 'unique' attribute may only be applied to 'our' variables/
+                ? '' : 'not ', "ok $test - $decl\n";
+    } else {
+        print("ok $test # Skip $decl\n");
+    }
     $test++;
 }
 
@@ -114,32 +132,30 @@
 # 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++;
 
-# 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");
+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");
+my $child = threads->new(sub { return (scalar(keys(%h))); })->join;
+is($child, 2, "keys correct in child");
 
-lock_keys (%h);
-delete $h{1};
+lock_keys(%h);
+delete($h{1});
 
-is (keys %h, 1, "keys correct in parent with restricted hash");
+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");
+$child = threads->new(sub { return (scalar(keys(%h))); })->join;
+is($child, 1, "keys correct in child with restricted hash");
 
-1;
+# EOF
Only in perl-threads/ext/threads/t: stack.t
Only in perl-threads/ext/threads/t: stack_env.t
diff -ur perl-current/ext/threads/t/stress_cv.t perl-threads/ext/threads/t/stress_cv.t
--- perl-current/ext/threads/t/stress_cv.t	2003-06-07 09:59:14.000000000 -0400
+++ perl-threads/ext/threads/t/stress_cv.t	2006-03-18 15:50:40.000000000 -0500
@@ -1,48 +1,57 @@
+use strict;
+use warnings;
+
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
     }
 }
 
 use ExtUtils::testlib;
-use strict;
-BEGIN { print "1..64\n" };
-use threads;
-
-
-print "ok 1\n";
 
-
-
-
-sub ok {	
+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";
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
 
-    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
-    
-    return $ok;
+    return ($ok);
 }
 
+BEGIN {
+    $| = 1;
+    print("1..63\n");   ### Number of tests that will be run ###
+};
 
-ok(2,1,"");
+use threads;
+ok(1, 1, 'Loaded');
 
+### Start of Testing ###
 
 my @threads;
-for(3..33) {
-  ok($_,1,"Multiple thread test");
-  push @threads ,threads->create(sub { my $i = shift; for(1..500000) { $i++}},$_);
+for (2..32) {
+    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");
+my $i = 33;
+for (@threads) {
+    $_->join;
+    ok($i++, 1 ,"Thread joined");
 }
 
+# EOF
diff -ur perl-current/ext/threads/t/stress_re.t perl-threads/ext/threads/t/stress_re.t
--- perl-current/ext/threads/t/stress_re.t	2003-06-07 09:59:14.000000000 -0400
+++ perl-threads/ext/threads/t/stress_re.t	2006-03-18 15:50:41.000000000 -0500
@@ -1,53 +1,60 @@
+use strict;
+use warnings;
+
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
     }
 }
 
 use ExtUtils::testlib;
-use strict;
-BEGIN { print "1..64\n" };
-use threads;
-
-
-print "ok 1\n";
-
 
-
-
-sub ok {	
+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";
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
 
-    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
-    
-    return $ok;
+    return ($ok);
 }
 
+BEGIN {
+    $| = 1;
+    print("1..63\n");   ### Number of tests that will be run ###
+};
+
+use threads;
+ok(1, 1, 'Loaded');
 
-ok(2,1,"");
+### Start of Testing ###
 
 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 $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',$_);
+for (2..32) {
+    ok($_, 1, "Multiple thread test");
+    push(@threads, threads->create('test9',$_));
 }
 
-my $i = 34;
-for(@threads) {
-  $_->join;
-  ok($i++,1,"Thread joined");
+my $i = 33;
+for (@threads) {
+    $_->join;
+    ok($i++, 1, "Thread joined");
 }
 
+# EOF
diff -ur perl-current/ext/threads/t/stress_string.t perl-threads/ext/threads/t/stress_string.t
--- perl-current/ext/threads/t/stress_string.t	2003-06-07 09:59:14.000000000 -0400
+++ perl-threads/ext/threads/t/stress_string.t	2006-03-18 15:50:42.000000000 -0500
@@ -1,51 +1,58 @@
+use strict;
+use warnings;
+
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
     }
 }
 
 use ExtUtils::testlib;
-use strict;
-BEGIN { print "1..64\n" };
-use threads;
-
-
-print "ok 1\n";
-
 
-
-
-sub ok {	
+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";
+    if ($ok) {
+        print("ok $id - $name\n");
+    } else {
+        print("not ok $id - $name\n");
+        printf("# Failed test at line %d\n", (caller)[2]);
+    }
 
-    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
-    
-    return $ok;
+    return ($ok);
 }
 
+BEGIN {
+    $| = 1;
+    print("1..63\n");   ### Number of tests that will be run ###
+};
+
+use threads;
+ok(1, 1, 'Loaded');
 
-ok(2,1,"");
+### Start of Testing ###
 
 sub test9 {
-  my $i = shift;
-  for(1..500000) { $i++};
+    my $i = shift;
+    for (1..500000) { $i++ };
 }
 my @threads;
-for(3..33) {
-  ok($_,1,"Multiple thread test");
-  push @threads ,threads->create('test9',$_);
+for (2..32) {
+    ok($_, 1, "Multiple thread test");
+    push(@threads, threads->create('test9', $_));
 }
 
-my $i = 34;
-for(@threads) {
-  $_->join;
-  ok($i++,1,"Thread joined");
+my $i = 33;
+for (@threads) {
+    $_->join;
+    ok($i++, 1, "Thread joined");
 }
 
+# EOF
Only in perl-threads/ext/threads/t: test.pl
diff -ur perl-current/ext/threads/t/thread.t perl-threads/ext/threads/t/thread.t
--- perl-current/ext/threads/t/thread.t	2005-04-18 22:05:44.000000000 -0400
+++ perl-threads/ext/threads/t/thread.t	2006-03-18 15:59:23.000000000 -0500
@@ -1,22 +1,32 @@
+use strict;
+use warnings;
 
 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 ($ENV{'PERL_CORE'}){
+        chdir 't';
+        unshift @INC, '../lib';
+    }
+    use Config;
+    if (! $Config{'useithreads'}) {
+        print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+        exit(0);
     }
-    require "test.pl";
+
+    require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
 }
 
 use ExtUtils::testlib;
-use strict;
-BEGIN { $| = 1; print "1..31\n" };
+
+BEGIN {
+    $| = 1;
+    print("1..31\n");   ### Number of tests that will be run ###
+};
+
 use threads;
 use threads::shared;
+print("ok 1 - Loaded\n");
 
-print "ok 1\n";
+### Start of Testing ###
 
 sub content {
     print shift;
@@ -30,9 +40,9 @@
     my $lock : shared;
     my $t;
     {
-	lock($lock);
-	$t = threads->new(sub { lock($lock); print "ok 5\n"});
-	print "ok 4\n";
+        lock($lock);
+        $t = threads->new(sub { lock($lock); print "ok 5\n"});
+        print "ok 4\n";
     }
     $t->join();
 }
@@ -42,8 +52,8 @@
     my $ret;
     print $val;
     if(@_) {
-	$ret = threads->new(\&dorecurse, @_);
-	$ret->join;
+        $ret = threads->new(\&dorecurse, @_);
+        $ret->join;
     }
 }
 {
@@ -62,14 +72,14 @@
 {
     my $lock : shared;
     sub islocked {
-	lock($lock);
-	my $val = shift;
-	my $ret;
-	print $val;
-	if (@_) {
-	    $ret = threads->new(\&islocked, shift);
-	}
-	return $ret;
+        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;
@@ -142,7 +152,7 @@
 }
 {
     # there is a little chance this test case will falsly fail
-    # since it tests rand	
+    # since it tests rand       
     my %rand : shared;
     rand(10);
     threads->new( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
@@ -160,8 +170,7 @@
 is($?, 0, 'coredump in global destruction');
 
 # test CLONE_SKIP() functionality
-
-{
+if ($] >= 5.008007) {
     my %c : shared;
     my %d : shared;
 
@@ -218,55 +227,63 @@
     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);
+        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");
+        {
+            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");
+        {
+            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");
+
+} else {
+    print("ok 27 # Skip objs clone skip at depth 0\n");
+    print("ok 28 # Skip objs clone skip at depth 1\n");
+    print("ok 29 # Skip objs clone skip at depth 2\n");
+    print("ok 30 # Skip counts of calls to CLONE_SKIP\n");
+    print("ok 31 # Skip counts of calls to DESTROY\n");
 }
 
+# EOF
diff -ur perl-current/ext/threads/threads.pm perl-threads/ext/threads/threads.pm
--- perl-current/ext/threads/threads.pm	2006-03-16 23:43:56.000000000 -0500
+++ perl-threads/ext/threads/threads.pm	2006-03-19 17:31:39.000000000 -0500
@@ -1,209 +1,383 @@
 package threads;
 
 use 5.008;
+
 use strict;
 use warnings;
-use Config;
+
+our $VERSION = '1.12';
 
 BEGIN {
-    unless ($Config{useithreads}) {
-	my @caller = caller(2);
-        die <<EOF;
-$caller[1] line $caller[2]:
-
-This Perl hasn't been configured and built properly for the threads
-module to work.  (The 'useithreads' configuration option hasn't been used.)
-
-Having threads support requires all of Perl and all of the XS modules in
-the Perl installation to be rebuilt, it is not just a question of adding
-the threads module.  (In other words, threaded and non-threaded Perls
-are binary incompatible.)
+    # Verify this Perl supports threads
+    use Config;
+    if (! $Config{useithreads}) {
+        die("This Perl not built to support threads\n");
+    }
 
-If you want to the use the threads module, please contact the people
-who built your Perl.
+    # Declare that we have been loaded
+    $threads::threads = 1;
 
-Cannot continue, aborting.
-EOF
-    }
+    # Complain if 'threads' is loaded after 'threads::shared'
+    if ($threads::shared::threads_shared) {
+        warn <<'_MSG_';
+Warning, threads::shared has already been loaded.  To
+enable shared variables, 'use threads' must be called
+before threads::shared or any module that uses it.
+_MSG_
+   }
 }
 
-use overload
-    '==' => \&equal,
-    'fallback' => 1;
 
-BEGIN {
-    warn "Warning, threads::shared has already been loaded. ".
-       "To enable shared variables for these modules 'use threads' ".
-       "must be called before any of those modules are loaded\n"
-               if($threads::shared::threads_shared);
-}
+# Load the XS code
+require XSLoader;
+XSLoader::load('threads', $VERSION);
 
-require Exporter;
-require DynaLoader;
 
-our @ISA = qw(Exporter DynaLoader);
+### Export ###
 
-our %EXPORT_TAGS = ( all => [qw(yield)]);
+sub import
+{
+    my $class = shift;   # Not used
 
-our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+    # Exported subroutines
+    my @EXPORT = qw(async);
 
-our @EXPORT = qw(
-async	
-);
-our $VERSION = '1.07_01';
+    # Handle args
+    while (my $sym = shift) {
+        if ($sym =~ /^stack/) {
+            threads->set_stack_size(shift);
 
+        } elsif ($sym =~ /all/) {
+            push(@EXPORT, qw(yield));
 
-# || 0 to ensure compatibility with previous versions
-sub equal { ($_[0]->tid == $_[1]->tid) || 0 }
+        } else {
+            push(@EXPORT, $sym);
+        }
+    }
 
-# use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2)
-# should also be faster
-sub async (&;@) { unshift @_,'threads'; goto &new }
+    # Export subroutine names
+    my $caller = caller();
+    foreach my $sym (@EXPORT) {
+        no strict 'refs';
+        *{$caller.'::'.$sym} = \&{$sym};
+    }
 
-sub object {
-    return undef unless @_ > 1;
-    foreach (threads->list) {
-        return $_ if $_->tid == $_[1];
+    # Set stack size via environment variable
+    if (exists($ENV{'PERL5_ITHREADS_STACK_SIZE'})) {
+        threads->set_stack_size($ENV{'PERL5_ITHREADS_STACK_SIZE'});
     }
-    return undef;
 }
 
-$threads::threads = 1;
 
-bootstrap threads $VERSION;
+### Methods, etc. ###
+
+# 'new' is an alias for 'create'
+*new = \&create;
 
-# why document 'new' then use 'create' in the tests!
-*create = \&new;
+# 'async' is a function alias for the 'threads->create()' method
+sub async (&;@)
+{
+    unshift(@_, 'threads');
+    # Use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2)
+    goto &create;
+}
 
-# Preloaded methods go here.
+# Overload '==' for checking thread object equality
+use overload (
+    '=='       => \&equal,
+    'fallback' => 1
+);
 
 1;
+
 __END__
 
 =head1 NAME
 
-threads - Perl extension allowing use of interpreter based threads from perl
+threads - Perl interpreter-based threads
+
+=head1 VERSION
+
+This document describes threads version 1.12
 
 =head1 SYNOPSIS
 
-    use threads;
+    use threads ('yield', 'stack_size' => 1_000_000);
 
     sub start_thread {
-	print "Thread started\n";
+        my @args = @_;
+        print "Thread started: @args\n";
     }
+    my $thread = threads->create('start_thread', 'argument');
+    $thread->join();
+
+    threads->create(sub { print("I am a thread\n"); })->join();
 
-    my $thread  = threads->create("start_thread","argument");
-    my $thread2 = $thread->create(sub { print "I am a thread"},"argument");
     my $thread3 = async { foreach (@files) { ... } };
+    $thread3->join();
+
+    # Invoke thread in list context so it can return a list
+    my ($thr) = threads->create(sub { return (qw/a b c/); });
+    my @results = $thr->join();
 
-    $thread->join();
     $thread->detach();
 
     $thread = threads->self();
-    $thread = threads->object( $tid );
+    $thread = threads->object($tid);
 
-    $thread->tid();
-    threads->tid();
-    threads->self->tid();
+    $tid = threads->tid();
+    $tid = threads->self->tid();
+    $tid = $thread->tid();
 
     threads->yield();
+    yield();
 
-    threads->list();
+    my @threads = threads->list();
+    my $thread_count = threads->list();
+
+    if ($thr1 == $thr2) {
+        ...
+    }
+
+    $stack_size = threads->get_stack_size();
+    $old_size = threads->set_stack_size(2_000_000);
 
 =head1 DESCRIPTION
 
-Perl 5.6 introduced something called interpreter threads.  Interpreter
-threads are different from "5005threads" (the thread model of Perl
-5.005) by creating a new perl interpreter per thread and not sharing
-any data or state between threads by default.
-
-Prior to perl 5.8 this has only been available to people embedding
-perl and for emulating fork() on windows.
-
-The threads API is loosely based on the old Thread.pm API. It is very
-important to note that variables are not shared between threads, all
-variables are per default thread local.  To use shared variables one
-must use threads::shared.
-
-It is also important to note that you must enable threads by doing
-C<use threads> as early as possible in the script itself and that it
-is not possible to enable threading inside an C<eval "">, C<do>,
-C<require>, or C<use>.  In particular, if you are intending to share
-variables with threads::shared, you must C<use threads> before you
-C<use threads::shared> and C<threads> will emit a warning if you do
-it the other way around.
+Perl 5.6 introduced something called interpreter threads.  Interpreter threads
+are different from I<5005threads> (the thread model of Perl 5.005) by creating
+a new Perl interpreter per thread, and not sharing any data or state between
+threads by default.
+
+Prior to Perl 5.8, this has only been available to people embedding Perl, and
+for emulating fork() on Windows.
+
+The I<threads> API is loosely based on the old Thread.pm API. It is very
+important to note that variables are not shared between threads, all variables
+are by default thread local.  To use shared variables one must use
+L<threads::shared>.
+
+It is also important to note that you must enable threads by doing C<use
+threads> as early as possible in the script itself, and that it is not
+possible to enable threading inside an C<eval "">, C<do>, C<require>, or
+C<use>.  In particular, if you are intending to share variables with
+L<threads::shared>, you must C<use threads> before you C<use threads::shared>.
+(C<threads> will emit a warning if you do it the other way around.)
 
 =over
 
-=item $thread = threads->create(function, LIST)
+=item $thr = threads->create(FUNCTION, ARGS)
+
+This will create a new thread that will begin execution with the specified
+entry point function, and give it the I<ARGS> list as parameters.  It will
+return the corresponding threads object, or C<undef> if thread creation failed.
+
+I<FUNCTION> may either be the name of a function, an anonymous subroutine, or
+a code ref.
+
+    my $thr = threads->create('func_name', ...);
+        # or
+    my $thr = threads->create(sub { ... }, ...);
+        # or
+    my $thr = threads->create(\&func, ...);
 
-This will create a new thread with the entry point function and give
-it LIST as parameters.  It will return the corresponding threads
-object, or C<undef> if thread creation failed. The new() method is an
-alias for create().
-
-=item $thread->join
-
-This will wait for the corresponding thread to join. When the thread
-finishes, join() will return the return values of the entry point
-function. If the thread has been detached, an error will be thrown.
+The thread may be created in I<list> context, or I<scalar> context as follows:
+
+    # Create thread in list context
+    my ($thr) = threads->create(...);
+
+    # Create thread in scalar context
+    my $thr = threads->create(...);
+
+This has consequences for the C<-E<gt>join()> method describe below.
+
+Although a thread may be created in I<void> context, to do so you must
+I<chain> either the C<-E<gt>join()> or C<-E<gt>detach()> method to the
+C<-E<gt>create()> call:
+
+    threads->create(...)->join();
+
+The C<-E<gt>new()> method is an alias for C<-E<gt>create()>.
+
+=item $thr->join()
+
+This will wait for the corresponding thread to complete its execution.  When
+the thread finishes, C<-E<gt>join()> will return the return value(s) of the
+entry point function.
 
 The context (void, scalar or list) of the thread creation is also the
-context for join().  This means that if you intend to return an array
-from a thread, you must use C<my ($thread) = threads->new(...)>, and
-that if you intend to return a scalar, you must use C<my $thread = ...>.
+context for C<-E<gt>join()>.  This means that if you intend to return an array
+from a thread, you must use C<my ($thr) = threads->create(...)>, and that
+if you intend to return a scalar, you must use C<my $thr = ...>:
+
+    # Create thread in list context
+    my ($thr1) = threads->create(sub {
+                                    my @results = qw(a b c);
+                                    return (@results);
+                                 };
+    # Retrieve list results from thread
+    my @res1 = $thr1->join();
+
+    # Create thread in scalar context
+    my $thr2 = threads->create(sub {
+                                    my $result = 42;
+                                    return ($result);
+                                 };
+    # Retrieve scalar result from thread
+    my $res2 = $thr2->join();
+
+If the program exits without all other threads having been either joined or
+detached, then a warning will be issued. (A program exits either because one
+of its threads explicitly calls L<exit()|perlfunc/"exit EXPR">, or in the case
+of the main thread, reaches the end of the main program file.)
+
+=item $thr->detach()
 
-If the program exits without all other threads having been either
-joined or detached, then a warning will be issued. (A program exits
-either because one of its threads explicitly calls exit(), or in the
-case of the main thread, reaches the end of the main program file.)
+Makes the thread unjoinable, and causes any eventual return value to be
+discarded.
 
+Calling C<-E<gt>join()> on a detached thread will cause an error to be thrown.
 
-=item $thread->detach
+=item threads->detach()
 
-Will make the thread unjoinable, and cause any eventual return value
-to be discarded.
+Class method that allows a thread to detach itself.
 
-=item threads->self
+=item threads->self()
 
-This will return the thread object for the current thread.
+Class method that allows a thread to obtain its own I<threads> object.
 
-=item $thread->tid
+=item $thr->tid()
 
-This will return the id of the thread.  Thread IDs are integers, with
-the main thread in a program being 0.  Currently Perl assigns a unique
-tid to every thread ever created in your program, assigning the first
-thread to be created a tid of 1, and increasing the tid by 1 for each
-new thread that's created.
+Returns the ID of the thread.  Thread IDs are unique integers with the main
+thread in a program being 0, and incrementing by 1 for every thread created.
 
-NB the class method C<< threads->tid() >> is a quick way to get the
-current thread id if you don't have your thread object handy.
+=item threads->tid()
 
-=item threads->object( tid )
+Class method that allows a thread to obtain its own ID.
 
-This will return the thread object for the thread associated with the
-specified tid.  Returns undef if there is no thread associated with the tid
-or no tid is specified or the specified tid is undef.
+=item threads->object($tid)
 
-=item threads->yield();
+This will return the I<threads> object for the I<active> thread associated
+with the specified thread ID.  Returns C<undef> if there is no thread
+associated with the TID, if the thread is joined or detached, if no TID is
+specified or if the specified TID is undef.
+
+=item threads->yield()
 
 This is a suggestion to the OS to let this thread yield CPU time to other
 threads.  What actually happens is highly dependent upon the underlying
 thread implementation.
 
-You may do C<use threads qw(yield)> then use just a bare C<yield> in your
+You may do C<use threads qw(yield)>, and then just use C<yield()> in your
 code.
 
-=item threads->list();
+=item threads->list()
+
+In a list context, returns a list of all non-joined, non-detached I<threads>
+objects.  In a scalar context, returns a count of the same.
+
+=item $thr1->equal($thr2)
+
+Tests if two threads objects are the same thread or not.  This is overloaded
+to the more natural form:
+
+    if ($thr1 == $thr2) {
+        print("Threads are the same\n");
+    }
 
-This will return a list of all non joined, non detached threads.
+(Thread comparison is based on thread IDs.)
 
 =item async BLOCK;
 
 C<async> creates a thread to execute the block immediately following
-it.  This block is treated as an anonymous sub, and so must have a
-semi-colon after the closing brace. Like C<< threads->new >>, C<async>
-returns a thread object.
+it.  This block is treated as an anonymous subroutine, and so must have a
+semi-colon after the closing brace.  Like C<threads->create()>, C<async>
+returns a I<threads> object.
+
+=item $thr->_handle()
+
+This I<private> method returns the memory location of the internal thread
+structure associated with a threads object.  For Win32, this is the handle
+returned by C<CreateThread>; for other platforms, it is the pointer returned
+by C<pthread_create>.
+
+This method is of no use for general Perl threads programming.  Its intent is
+to provide other (XS-based) thread modules with the capability to access, and
+possibly manipulate, the underlying thread structure associated with a Perl
+thread.
+
+=item threads->_handle()
+
+Class method that allows a thread to obtain its own I<handle>.
+
+=back
+
+=head1 THREAD STACK SIZE
+
+The default per-thread stack size for different platforms varies
+significantly, and is almost always far more than is needed for most
+applications.  On Win32, Perl's makefile explicitly sets the default stack to
+16 MB; on most other platforms, the system default is used, which again may be
+much larger than is needed (e.g., the Linux default is around 8 MB).
+
+By tuning the stack size to more accurately reflect your application's needs,
+you may significantly reduce your application's memory usage, and increase the
+number of simultaneously running threads.
+
+N.B., on Windows, Address space allocation granularity is 64 KB, therefore,
+setting the stack smaller than that on Win32 Perl will not save any more
+memory.
+
+=over
+
+=item threads->get_stack_size();
+
+Returns the current default per-thread stack size.  The default is zero, which
+means the system default stack size is currently in use.
+
+=item $size = $thr->get_stack_size();
+
+Returns the stack size for a particular thread.  A return value of zero
+indicates the system default stack size was used for the thread.
+
+=item $old_size = threads->set_stack_size($new_size);
+
+Sets a new default per-thread stack size, and returns the previous setting.
+Threads created after the stack size is set will then either call
+C<pthread_attr_setstacksize()> I<(for pthreads platforms)>, or supply the
+stack size to C<CreateThread()> I<(for Win32 Perl)>.
+
+(Obviously, this call does not affect any currently extant threads.)
+
+=item use threads ('stack_size' => VALUE);
+
+This sets the default per-thread stack size at the start of the application.
+
+=item $ENV{'PERL5_ITHREADS_STACK_SIZE'}
+
+The default per-thread stack size may be set at the start of the application
+through the use of the environment variable C<PERL5_ITHREADS_STACK_SIZE>:
+
+    PERL5_ITHREADS_STACK_SIZE=1000000
+    export PERL5_ITHREADS_STACK_SIZE
+    perl -e'use threads; print(threads->get_stack_size(), "\n")'
+
+This value overrides any C<stack_size> parameter given to C<use threads>.  Its
+primary purpose is to permit setting the per-thread stack size for legacy
+threaded applications.
+
+=item threads->create({'stack_size' => VALUE}, FUNCTION, ARGS)
+
+This change to the thread creation method permits specifying the stack size
+for an individual thread.
+
+=item $thr2 = $thr1->create(FUNCTION, ARGS)
+
+This creates a new thread (C<$thr2>) that inherits the stack size from an
+existing thread (C<$thr1>).  This is shorthand for the following:
+
+    my $stack_size = $thr1->get_stack_size();
+    my $thr2 = threads->create({'stack_size' => $stack_size}, FUNCTION, ARGS);
 
 =back
 
@@ -211,88 +385,121 @@
 
 =over 4
 
-=item A thread exited while %d other threads were still running
+=item A thread exited while # other threads were still running
 
-A thread (not necessarily the main thread) exited while there were
-still other threads running.  Usually it's a good idea to first collect
-the return values of the created threads by joining them, and only then
-exit from the main thread.
+A thread (not necessarily the main thread) exited while there were still other
+threads running.  Usually, it's a good idea to first collect the return values
+of the created threads by joining them, and only then exit from the main
+thread.
 
 =back
 
-=head1 TODO
+=head1 ERRORS
+
+=over 4
 
-The current implementation of threads has been an attempt to get
-a correct threading system working that could be built on, 
-and optimized, in newer versions of perl.
-
-Currently the overhead of creating a thread is rather large,
-also the cost of returning values can be large. These are areas
-were there most likely will be work done to optimize what data
-that needs to be cloned.
+=item Cannot change stack size of an existing thread
 
-=head1 BUGS
+The stack size of currently extant threads cannot be changed, therefore, the
+following results in the above error:
 
-=over
+    $thr->set_stack_size($size);
 
-=item Parent-Child threads.
+=item This Perl not built to support threads
 
-On some platforms it might not be possible to destroy "parent"
-threads while there are still existing child "threads".
+The particular copy of Perl that you're trying to use was not built using the
+C<useithreads> configuration option.
 
-This will possibly be fixed in later versions of perl.
+Having threads support requires all of Perl and all of the XS modules in the
+Perl installation to be rebuilt; it is not just a question of adding the
+L<threads> module (i.e., threaded and non-threaded Perls are binary
+incompatible.)
 
-=item tid is I32
+=back
+
+=head1 BUGS
 
-The thread id is a 32 bit integer, it can potentially overflow.
-This might be fixed in a later version of perl.
+=over
 
-=item Returning objects
+=item Parent-child threads
 
-When you return an object the entire stash that the object is blessed
-as well.  This will lead to a large memory usage.  The ideal situation
-would be to detect the original stash if it existed.
+On some platforms, it might not be possible to destroy I<parent> threads while
+there are still existing I<child> threads.
 
 =item Creating threads inside BEGIN blocks
 
-Creating threads inside BEGIN blocks (or during the compilation phase
-in general) does not work.  (In Windows, trying to use fork() inside
-BEGIN blocks is an equally losing proposition, since it has been
-implemented in very much the same way as threads.)
+Creating threads inside BEGIN blocks (or during the compilation phase in
+general) does not work.  (In Windows, trying to use fork() inside BEGIN blocks
+is an equally losing proposition, since it has been implemented in very much
+the same way as threads.)
 
 =item PERL_OLD_SIGNALS are not threadsafe, will not be.
 
-If your Perl has been built with PERL_OLD_SIGNALS (one has
-to explicitly add that symbol to ccflags, see C<perl -V>),
-signal handling is not threadsafe.
+If your Perl has been built with PERL_OLD_SIGNALS (one has to explicitly add
+that symbol to I<ccflags>, see C<perl -V>), signal handling is not threadsafe.
+
+=item Perl Bugs and the CPAN Version of L<threads>
+
+Support for threads extents beyond the code in this module (i.e.,
+F<threads.pm> and F<threads.xs>), and into the Perl iterpreter itself.  Older
+versions of Perl contain bugs that may manifest themselves despite using the
+latest version of L<threads> from CPAN.  There is no workaround for this other
+than upgrading to the lastest version of Perl.
+
+(Before you consider posting a bug report, please consult, and possibly post a
+message to the discussion forum to see if what you've encountered is a known
+problem.)
 
 =back
 
-=head1 AUTHOR and COPYRIGHT
+View existing bug reports at, and submit any new bugs, problems, patches, etc.
+to: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=threads>
+
+=head1 REQUIREMENTS
+
+Perl 5.8.0 or later
+
+=head1 SEE ALSO
+
+L<threads> Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/threads>
+
+Annotated POD for L<threads>:
+L<http://annocpan.org/~JDHEDDEN/threads-1.12/shared.pm>
+
+L<threads::shared>, L<perlthrtut>
+
+L<http://www.perl.com/pub/a/2002/06/11/threads.html> and
+L<http://www.perl.com/pub/a/2002/09/04/threads.html>
+
+Perl threads mailing list:
+L<http://lists.cpan.org/showlist.cgi?name=iThreads>
 
-Arthur Bergman E<lt>sky at nanisky.comE<gt>
+Stack size discussion:
+L<http://www.perlmonks.org/?node_id=532956>
+
+=head1 AUTHOR
+
+Artur Bergman E<lt>sky AT crucially DOT netE<gt>
 
 threads is released under the same license as Perl.
 
-Thanks to
+CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org>
+
+=head1 ACKNOWLEDGEMENTS
 
-Richard Soderberg E<lt>perl at crystalflame.netE<gt>
+Richard Soderberg E<lt>perl AT crystalflame DOT netE<gt> -
 Helping me out tons, trying to find reasons for races and other weird bugs!
 
-Simon Cozens E<lt>simon at brecon.co.ukE<gt>
+Simon Cozens E<lt>simon AT brecon DOT co DOT ukE<gt> -
 Being there to answer zillions of annoying questions
 
-Rocco Caputo E<lt>troc at netrus.netE<gt>
+Rocco Caputo E<lt>troc AT netrus DOT netE<gt>
 
-Vipul Ved Prakash E<lt>mail at vipul.netE<gt>
-Helping with debugging.
-
-please join perl-ithreads@perl.org for more information
-
-=head1 SEE ALSO
+Vipul Ved Prakash E<lt>mail AT vipul DOT netE<gt> -
+Helping with debugging
 
-L<threads::shared>, L<perlthrtut>, 
-L<http://www.perl.com/pub/a/2002/06/11/threads.html>,
-L<perlcall>, L<perlembed>, L<perlguts>
+Dean Arnold E<lt>darnold AT presicient DOT comE<gt> -
+Stack size API
 
 =cut
diff -ur perl-current/ext/threads/threads.xs perl-threads/ext/threads/threads.xs
--- perl-current/ext/threads/threads.xs	2006-03-16 23:43:56.000000000 -0500
+++ perl-threads/ext/threads/threads.xs	2006-03-19 16:45:46.000000000 -0500
@@ -2,56 +2,83 @@
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
+#define NEED_newRV_noinc
+#define NEED_sv_2pv_nolen
+#include "ppport.h"
+#include "threads.h"
 
 #ifdef USE_ITHREADS
 
-
 #ifdef WIN32
-#include <windows.h>
-#include <win32thread.h>
+#  include <windows.h>
+   /* Supposed to be in Winbase.h */
+#  ifndef STACK_SIZE_PARAM_IS_A_RESERVATION
+#    define STACK_SIZE_PARAM_IS_A_RESERVATION 0x00010000
+#  endif
+#  include <win32thread.h>
 #else
-#ifdef OS2
+#  ifdef OS2
 typedef perl_os_thread pthread_t;
-#else
-#include <pthread.h>
-#endif
-#include <thread.h>
-#define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
-#ifdef OLD_PTHREADS_API
-#define PERL_THREAD_DETACH(t) pthread_detach(&(t))
-#else
-#define PERL_THREAD_DETACH(t) pthread_detach((t))
-#endif  /* OLD_PTHREADS_API */
+#  else
+#    include <pthread.h>
+#  endif
+#  include <thread.h>
+#  define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
+#  ifdef OLD_PTHREADS_API
+#    define PERL_THREAD_DETACH(t) pthread_detach(&(t))
+#  else
+#    define PERL_THREAD_DETACH(t) pthread_detach((t))
+#  endif
 #endif
 
-
-
-
 /* Values for 'state' member */
-#define PERL_ITHR_JOINABLE		0
-#define PERL_ITHR_DETACHED		1
-#define PERL_ITHR_FINISHED		4
-#define PERL_ITHR_JOINED		2
+#define PERL_ITHR_JOINABLE      0
+#define PERL_ITHR_DETACHED      1
+#define PERL_ITHR_JOINED        2
+#define PERL_ITHR_FINISHED      4
 
 typedef struct ithread_s {
-    struct ithread_s *next;	/* Next thread in the list */
-    struct ithread_s *prev;	/* Prev thread in the list */
-    PerlInterpreter *interp;	/* The threads interpreter */
-    I32 tid;              	/* Threads module's thread id */
-    perl_mutex mutex; 		/* Mutex for updating things in this struct */
-    I32 count;			/* How many SVs have a reference to us */
-    signed char state;		/* Are we detached ? */
-    int gimme;			/* Context of create */
-    SV* init_function;          /* Code to run */
-    SV* params;                 /* Args to pass function */
+    struct ithread_s *next;     /* Next thread in the list */
+    struct ithread_s *prev;     /* Prev thread in the list */
+    PerlInterpreter *interp;    /* The threads interpreter */
+    /* Under PERL_IMPLICIT_SYS even the call to PerlMemShared_free() uses
+     * aTHX, so the perl interpreter should not be freed before the threads
+     * structure is deallocated.  Thus, we need two copies of the interpreter
+     * pointer - one for destruction in the thread's context; the other for
+     * freeing after the thread structure is deallocated.
+     */
+    PerlInterpreter *free_interp;
+    UV tid;                     /* Threads module's thread id */
+    perl_mutex mutex;           /* Mutex for updating things in this struct */
+    UV count;                   /* How many SVs have a reference to us */
+    int state;                  /* Detached, joined, finished, etc. */
+    int gimme;                  /* Context of create */
+    SV *init_function;          /* Code to run */
+    SV *params;                 /* Args to pass function */
 #ifdef WIN32
-	DWORD	thr;            /* OS's idea if thread id */
-	HANDLE handle;          /* OS's waitable handle */
+    DWORD  thr;                 /* OS's idea if thread id */
+    HANDLE handle;              /* OS's waitable handle */
 #else
-  	pthread_t thr;          /* OS's handle for the thread */
+    pthread_t thr;              /* OS's handle for the thread */
 #endif
+    UV stack_size;
 } ithread;
 
+/* Linked list of all threads */
+ithread *threads;
+
+/* Protects the creation and destruction of threads*/
+static perl_mutex create_destruct_mutex;
+
+UV tid_counter = 0;
+UV active_threads = 0;
+#ifdef THREAD_CREATE_NEEDS_STACK
+UV default_stack_size = THREAD_CREATE_NEEDS_STACK;
+#else
+UV default_stack_size = 0;
+#endif
+
+
 #define MY_CXT_KEY "threads::_guts" XS_VERSION
 
 typedef struct {
@@ -61,750 +88,910 @@
 START_MY_CXT
 
 
-ithread *threads;
-
-/* Macros to supply the aTHX_ in an embed.h like manner */
-#define ithread_join(thread)		Perl_ithread_join(aTHX_ thread)
-#define ithread_DESTROY(thread)		Perl_ithread_DESTROY(aTHX_ thread)
-#define ithread_CLONE(thread)		Perl_ithread_CLONE(aTHX_ thread)
-#define ithread_detach(thread)		Perl_ithread_detach(aTHX_ thread)
-#define ithread_tid(thread)		((thread)->tid)
-#define ithread_yield(thread)		(YIELD);
-
-static perl_mutex create_destruct_mutex;  /* protects the creation and destruction of threads*/
-
-I32 tid_counter = 0;
-I32 known_threads = 0;
-I32 active_threads = 0;
-
-
-void Perl_ithread_set (pTHX_ ithread* thread)
+/* Used by Perl interpreter for thread context switching */
+static void
+Perl_ithread_set(pTHX_ ithread *thread)
 {
     dMY_CXT;
     MY_CXT.thread = thread;
 }
 
-ithread* Perl_ithread_get (pTHX) {
+static ithread *
+Perl_ithread_get(pTHX)
+{
     dMY_CXT;
-    return MY_CXT.thread;
+    return (MY_CXT.thread);
 }
 
 
-/* free any data (such as the perl interpreter) attached to an
- * ithread structure. This is a bit like undef on SVs, where the SV
- * isn't freed, but the PVX is.
- * Must be called with thread->mutex already held
+/* Free any data (such as the Perl interpreter) attached to an ithread
+ * structure.  This is a bit like undef on SVs, where the SV isn't freed,
+ * but the PVX is.  Must be called with thread->mutex already held.
  */
-
 static void
-S_ithread_clear(pTHX_ ithread* thread)
+S_ithread_clear(pTHX_ ithread *thread)
 {
-    PerlInterpreter *interp;
-    assert(thread->state & PERL_ITHR_FINISHED &&
-    	    (thread->state & PERL_ITHR_DETACHED ||
-	    thread->state & PERL_ITHR_JOINED));
-
-    interp = thread->interp;
+    PerlInterpreter *interp = thread->interp;
     if (interp) {
-	dTHXa(interp);
-	ithread* current_thread;
-#ifdef OEMVS
-	void *ptr;
-#endif
-	PERL_SET_CONTEXT(interp);
-	current_thread = Perl_ithread_get(aTHX);
-	Perl_ithread_set(aTHX_ thread);
-	
-	SvREFCNT_dec(thread->params);
-
-	thread->params = Nullsv;
-	perl_destruct(interp);
-	thread->interp = NULL;
+        dTHXa(interp);
+        ithread *current_thread;
+
+        PERL_SET_CONTEXT(interp);
+        current_thread = Perl_ithread_get(aTHX);
+        Perl_ithread_set(aTHX_ thread);
+
+        SvREFCNT_dec(thread->init_function);
+
+        SvREFCNT_dec(thread->params);
+        thread->params = Nullsv;
+
+        perl_destruct(interp);
+        thread->interp = NULL;
     }
-    if (interp)
-	perl_free(interp);
     PERL_SET_CONTEXT(aTHX);
 }
 
 
-/*
- *  free an ithread structure and any attached data if its count == 0
- */
-void
-Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
+/* Free an ithread structure and any attached data if its count == 0 */
+static void
+Perl_ithread_destruct(pTHX_ ithread *thread)
 {
-	MUTEX_LOCK(&thread->mutex);
-	if (!thread->next) {
-	    MUTEX_UNLOCK(&thread->mutex);
-	    Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
-	}
-	if (thread->count != 0) {
-		MUTEX_UNLOCK(&thread->mutex);
-		return;
-	}
-	MUTEX_LOCK(&create_destruct_mutex);
-	/* Remove from circular list of threads */
-	if (thread->next == thread) {
-	    /* last one should never get here ? */
-	    threads = NULL;
-        }
-	else {
-	    thread->next->prev = thread->prev;
-	    thread->prev->next = thread->next;
-	    if (threads == thread) {
-		threads = thread->next;
-	    }
-	    thread->next = NULL;
-	    thread->prev = NULL;
-	}
-	known_threads--;
-	assert( known_threads >= 0 );
-#if 0
-        Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
-	          thread->tid,thread->interp,aTHX, known_threads);
-#endif
-	MUTEX_UNLOCK(&create_destruct_mutex);
-	/* Thread is now disowned */
-
-	S_ithread_clear(aTHX_ thread);
-        aTHX = PL_curinterp;
-	MUTEX_UNLOCK(&thread->mutex);
-	MUTEX_DESTROY(&thread->mutex);
-#ifdef WIN32
-	if (thread->handle)
-	    CloseHandle(thread->handle);
-	thread->handle = 0;
+    PerlInterpreter *interp;
+#ifdef WIN32
+    HANDLE handle;
 #endif
-        PerlMemShared_free(thread);
-}
 
-int
-Perl_ithread_hook(pTHX)
-{
-    int veto_cleanup = 0;
-    MUTEX_LOCK(&create_destruct_mutex);
-    if (aTHX == PL_curinterp && active_threads != 1) {
-	if (ckWARN_d(WARN_THREADS))
-	    Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
-						      (IV)active_threads);
-	veto_cleanup = 1;
+    MUTEX_LOCK(&thread->mutex);
+
+    /* Thread is still in use */
+    if (thread->count != 0) {
+        MUTEX_UNLOCK(&thread->mutex);
+        return;
     }
+
+    /* Remove from circular list of threads */
+    MUTEX_LOCK(&create_destruct_mutex);
+    thread->next->prev = thread->prev;
+    thread->prev->next = thread->next;
+    thread->next = NULL;
+    thread->prev = NULL;
     MUTEX_UNLOCK(&create_destruct_mutex);
-    return veto_cleanup;
+
+    /* Thread is now disowned */
+    S_ithread_clear(aTHX_ thread);
+    interp = thread->free_interp;
+    thread->free_interp = NULL;
+#ifdef WIN32
+    handle = thread->handle;
+    thread->handle = 0;
+#endif
+    MUTEX_UNLOCK(&thread->mutex);
+    MUTEX_DESTROY(&thread->mutex);
+    PerlMemShared_free(thread);
+    if (interp)
+        perl_free(interp);
+#ifdef WIN32
+    if (handle)
+        CloseHandle(thread);
+#endif
 }
 
-void
+
+/* Detach a thread */
+static void
 Perl_ithread_detach(pTHX_ ithread *thread)
 {
+    int cleanup;
+
     MUTEX_LOCK(&thread->mutex);
-    if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
-	thread->state |= PERL_ITHR_DETACHED;
+    if (! (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
+        /* Mark as detached */
+        thread->state |= PERL_ITHR_DETACHED;
 #ifdef WIN32
-	CloseHandle(thread->handle);
-	thread->handle = 0;
+        /* Windows has no 'detach thread' function */
 #else
-	PERL_THREAD_DETACH(thread->thr);
+        PERL_THREAD_DETACH(thread->thr);
 #endif
     }
-    if ((thread->state & PERL_ITHR_FINISHED) &&
-        (thread->state & PERL_ITHR_DETACHED)) {
-	MUTEX_UNLOCK(&thread->mutex);
-	Perl_ithread_destruct(aTHX_ thread, "detach");
-    }
-    else {
-	MUTEX_UNLOCK(&thread->mutex);
+    cleanup = ((thread->state & PERL_ITHR_FINISHED) &&
+               (thread->state & PERL_ITHR_DETACHED));
+    MUTEX_UNLOCK(&thread->mutex);
+
+    if (cleanup)
+        Perl_ithread_destruct(aTHX_ thread);
+}
+
+
+int
+Perl_ithread_hook(pTHX)
+{
+    int veto_cleanup = 0;
+    MUTEX_LOCK(&create_destruct_mutex);
+    if ((aTHX == PL_curinterp) && (active_threads > 1)) {
+        if (ckWARN_d(WARN_THREADS)) {
+            Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", (IV)active_threads);
+        }
+        veto_cleanup = 1;
     }
+    MUTEX_UNLOCK(&create_destruct_mutex);
+    return (veto_cleanup);
 }
 
+
 /* MAGIC (in mg.h sense) hooks */
 
 int
 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
 {
-    ithread *thread = (ithread *) mg->mg_ptr;
+    ithread *thread = (ithread *)mg->mg_ptr;
     SvIV_set(sv, PTR2IV(thread));
     SvIOK_on(sv);
-    return 0;
+    return (0);
 }
 
 int
 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
 {
-    ithread *thread = (ithread *) mg->mg_ptr;
+    int cleanup;
+
+    ithread *thread = (ithread *)mg->mg_ptr;
     MUTEX_LOCK(&thread->mutex);
-    thread->count--;
-    if (thread->count == 0) {
-       if(thread->state & PERL_ITHR_FINISHED &&
-          (thread->state & PERL_ITHR_DETACHED ||
-           thread->state & PERL_ITHR_JOINED))
-       {
-            MUTEX_UNLOCK(&thread->mutex);
-            Perl_ithread_destruct(aTHX_ thread, "no reference");
-       }
-       else {
-	    MUTEX_UNLOCK(&thread->mutex);
-       }    
-    }
-    else {
-	MUTEX_UNLOCK(&thread->mutex);
-    }
-    return 0;
+    cleanup = ((--thread->count == 0) &&
+               (thread->state & PERL_ITHR_FINISHED) &&
+               (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)));
+    MUTEX_UNLOCK(&thread->mutex);
+
+    if (cleanup)
+        Perl_ithread_destruct(aTHX_ thread);
+    return (0);
 }
 
 int
 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 {
-    ithread *thread = (ithread *) mg->mg_ptr;
+    ithread *thread = (ithread *)mg->mg_ptr;
     MUTEX_LOCK(&thread->mutex);
     thread->count++;
     MUTEX_UNLOCK(&thread->mutex);
-    return 0;
+    return (0);
 }
 
 MGVTBL ithread_vtbl = {
- ithread_mg_get,	/* get */
- 0,			/* set */
- 0,			/* len */
- 0,			/* clear */
- ithread_mg_free,	/* free */
- 0,			/* copy */
- ithread_mg_dup		/* dup */
+    ithread_mg_get,     /* get */
+    0,                  /* set */
+    0,                  /* len */
+    0,                  /* clear */
+    ithread_mg_free,    /* free */
+    0,                  /* copy */
+    ithread_mg_dup      /* dup */
 };
 
 
-/*
- *	Starts executing the thread. Needs to clean up memory a tad better.
- *      Passed as the C level function to run in the new thread
- */
-
-#ifdef WIN32
-THREAD_RET_TYPE
-Perl_ithread_run(LPVOID arg) {
-#else
-void*
-Perl_ithread_run(void * arg) {
-#endif
-	ithread* thread = (ithread*) arg;
-	dTHXa(thread->interp);
-	PERL_SET_CONTEXT(thread->interp);
-	Perl_ithread_set(aTHX_ thread);
-
-#if 0
-	/* Far from clear messing with ->thr child-side is a good idea */
-	MUTEX_LOCK(&thread->mutex);
-#ifdef WIN32
-	thread->thr = GetCurrentThreadId();
-#else
-	thread->thr = pthread_self();
-#endif
- 	MUTEX_UNLOCK(&thread->mutex);
-#endif
-
-	PL_perl_destruct_level = 2;
-
-	{
-		AV* params = (AV*) SvRV(thread->params);
-		I32 len = av_len(params)+1;
-		int i;
-		dSP;
-		ENTER;
-		SAVETMPS;
-		PUSHMARK(SP);
-		for(i = 0; i < len; i++) {
-		    XPUSHs(av_shift(params));
-		}
-		PUTBACK;
-		len = call_sv(thread->init_function, thread->gimme|G_EVAL);
-
-		SPAGAIN;
-		for (i=len-1; i >= 0; i--) {
-		  SV *sv = POPs;
-		  av_store(params, i, SvREFCNT_inc(sv));
-		}
-		if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
-		    Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
-		}
-		FREETMPS;
-		LEAVE;
-		SvREFCNT_dec(thread->init_function);
-	}
-
-	PerlIO_flush((PerlIO*)NULL);
-	MUTEX_LOCK(&thread->mutex);
-	thread->state |= PERL_ITHR_FINISHED;
-
-	if (thread->state & PERL_ITHR_DETACHED) {
-		MUTEX_UNLOCK(&thread->mutex);
-		Perl_ithread_destruct(aTHX_ thread, "detached finish");
-	} else {
-		MUTEX_UNLOCK(&thread->mutex);
-	}
-	MUTEX_LOCK(&create_destruct_mutex);
-	active_threads--;
-	assert( active_threads >= 0 );
-	MUTEX_UNLOCK(&create_destruct_mutex);
-
-#ifdef WIN32
-	return (DWORD)0;
-#else
-	return 0;
-#endif
-}
-
-SV *
+/* Type conversion helper functions */
+static SV *
 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
 {
     SV *sv;
     MAGIC *mg;
     if (inc) {
-	MUTEX_LOCK(&thread->mutex);
-	thread->count++;
-	MUTEX_UNLOCK(&thread->mutex);
-    }
-    if (!obj)
-     obj = newSV(0);
-    sv = newSVrv(obj,classname);
-    sv_setiv(sv,PTR2IV(thread));
-    mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
+        MUTEX_LOCK(&thread->mutex);
+        thread->count++;
+        MUTEX_UNLOCK(&thread->mutex);
+    }
+    if (! obj) {
+        obj = newSV(0);
+    }
+    sv = newSVrv(obj, classname);
+    sv_setiv(sv, PTR2IV(thread));
+    mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &ithread_vtbl, (char *)thread, 0);
     mg->mg_flags |= MGf_DUP;
     SvREADONLY_on(sv);
-    return obj;
+    return (obj);
 }
 
-ithread *
+static ithread *
 SV_to_ithread(pTHX_ SV *sv)
 {
-    if (SvROK(sv))
-     {
-      return INT2PTR(ithread*, SvIV(SvRV(sv)));
-     }
-    else
-     {
-      return Perl_ithread_get(aTHX);
-     }
+    if (SvROK(sv)) {
+      return (INT2PTR(ithread *, SvIV(SvRV(sv))));
+    }
+    return (Perl_ithread_get(aTHX));
 }
 
-/*
- * ithread->create(); ( aka ithread->new() )
- * Called in context of parent thread
- */
 
-SV *
-Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
+/* Starts executing the thread.
+ * Passed as the C level function to run in the new thread.
+ */
+#ifdef WIN32
+static THREAD_RET_TYPE
+Perl_ithread_run(LPVOID arg)
+#else
+static void *
+Perl_ithread_run(void * arg)
+#endif
 {
-	ithread*	thread;
-	CLONE_PARAMS	clone_param;
-	ithread*        current_thread = Perl_ithread_get(aTHX);
+    ithread *thread = (ithread *)arg;
+    int cleanup;
+
+    dTHXa(thread->interp);
+    PERL_SET_CONTEXT(thread->interp);
+    Perl_ithread_set(aTHX_ thread);
+
+    PL_perl_destruct_level = 2;
+
+    {
+        AV *params = (AV *)SvRV(thread->params);
+        IV len = av_len(params)+1;
+        int i;
+
+        dSP;
+        ENTER;
+        SAVETMPS;
+
+        /* Put args on the stack */
+        PUSHMARK(SP);
+        for (i=0; i < len; i++) {
+            XPUSHs(av_shift(params));
+        }
+        PUTBACK;
+
+        /* Run the specified function */
+        len = call_sv(thread->init_function, thread->gimme|G_EVAL);
+
+        /* Remove args from stack and put back in params array */
+        SPAGAIN;
+        for (i=len-1; i >= 0; i--) {
+          SV *sv = POPs;
+          av_store(params, i, SvREFCNT_inc(sv));
+        }
+
+        /* Check for failure */
+        if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
+            Perl_warn(aTHX_ "Thread failed to start: %" SVf, ERRSV);
+        }
+
+        FREETMPS;
+        LEAVE;
+    }
+
+    PerlIO_flush((PerlIO *)NULL);
+
+    MUTEX_LOCK(&thread->mutex);
+    /* Mark as finished */
+    thread->state |= PERL_ITHR_FINISHED;
+    /* Cleanup if detached */
+    cleanup = (thread->state & PERL_ITHR_DETACHED);
+    MUTEX_UNLOCK(&thread->mutex);
+
+    if (cleanup)
+        Perl_ithread_destruct(aTHX_ thread);
+
+    MUTEX_LOCK(&create_destruct_mutex);
+    active_threads--;
+    MUTEX_UNLOCK(&create_destruct_mutex);
+
+#ifdef WIN32
+    return ((DWORD)0);
+#else
+    return (0);
+#endif
+}
+
+
+/* threads->create()
+ * Called in context of parent thread.
+ */
+static SV *
+Perl_ithread_create(
+        pTHX_ SV *obj,
+        char     *classname,
+        SV       *init_function,
+        UV        stack_size,
+        SV       *params)
+{
+    ithread     *thread;
+    CLONE_PARAMS clone_param;
+    ithread     *current_thread = Perl_ithread_get(aTHX);
 
-	SV**            tmps_tmp = PL_tmps_stack;
-	I32             tmps_ix  = PL_tmps_ix;
+    SV         **tmps_tmp = PL_tmps_stack;
+    IV           tmps_ix  = PL_tmps_ix;
 #ifndef WIN32
-	int		failure;
-	const char*	panic = NULL;
+    int          failure;
+    const char  *panic = NULL;
 #endif
 
+    MUTEX_LOCK(&create_destruct_mutex);
+
+    thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
+    if (!thread) {
+        MUTEX_UNLOCK(&create_destruct_mutex);
+        PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
+        my_exit(1);
+    }
+    Zero(thread, 1 ,ithread);
+
+    /* Add to threads list */
+    thread->next = threads;
+    thread->prev = threads->prev;
+    threads->prev = thread;
+    thread->prev->next = thread;
+
+    /* Set count to 1 immediately in case thread exits before
+     * we return to caller!
+     */
+    thread->count = 1;
+
+    MUTEX_INIT(&thread->mutex);
+    thread->tid = tid_counter++;
+    thread->stack_size = (stack_size) ? stack_size : default_stack_size;
+    thread->gimme = GIMME_V;
+
+    /* "Clone" our interpreter into the thread's interpreter.
+     * This gives thread access to "static data" and code.
+     */
+    PerlIO_flush((PerlIO *)NULL);
+    Perl_ithread_set(aTHX_ thread);
+
+    SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */
+    PL_srand_called = FALSE;   /* Set it to false so we can detect if it gets
+                                  set during the clone */
+
+#ifdef WIN32
+    thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
+#else
+    thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
+#endif
+    thread->free_interp = thread->interp;
+
+    /* perl_clone() leaves us in new interpreter's context.  As it is tricky
+     * to spot an implicit aTHX, create a new scope with aTHX matching the
+     * context for the duration of our work for new interpreter.
+     */
+    {
+        dTHXa(thread->interp);
+
+        MY_CXT_CLONE;
+
+        /* Here we remove END blocks since they should only run in the thread
+         * they are created
+         */
+        SvREFCNT_dec(PL_endav);
+        PL_endav = newAV();
+        clone_param.flags = 0;
+        thread->init_function = sv_dup(init_function, &clone_param);
+        if (SvREFCNT(thread->init_function) == 0) {
+            SvREFCNT_inc(thread->init_function);
+        }
+
+        thread->params = sv_dup(params, &clone_param);
+        SvREFCNT_inc(thread->params);
+
+        /* The code below checks that anything living on the tmps stack and
+         * has been cloned (so it lives in the ptr_table) has a refcount
+         * higher than 0.
+         *
+         * If the refcount is 0 it means that a something on the stack/context
+         * was holding a reference to it and since we init_stacks() in
+         * perl_clone that won't get cleaned and we will get a leaked scalar.
+         * The reason it was cloned was that it lived on the @_ stack.
+         *
+         * Example of this can be found in bugreport 15837 where calls in the
+         * parameter list end up as a temp.
+         *
+         * One could argue that this fix should be in perl_clone.
+         */
+        while (tmps_ix > 0) {
+            SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
+            tmps_ix--;
+            if (sv && SvREFCNT(sv) == 0) {
+                SvREFCNT_inc(sv);
+                SvREFCNT_dec(sv);
+            }
+        }
+
+        SvTEMP_off(thread->init_function);
+        ptr_table_free(PL_ptr_table);
+        PL_ptr_table = NULL;
+        PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+    }
+    Perl_ithread_set(aTHX_ current_thread);
+    PERL_SET_CONTEXT(aTHX);
+
+    /* Create/start the thread */
+#ifdef WIN32
+    thread->handle = CreateThread(NULL,
+                                  thread->stack_size,
+                                  Perl_ithread_run,
+                                  (LPVOID)thread,
+                                  STACK_SIZE_PARAM_IS_A_RESERVATION,
+                                  &thread->thr);
+#else
+    {
+        static pthread_attr_t attr;
+        static int attr_inited = 0;
+        static int attr_joinable = PTHREAD_CREATE_JOINABLE;
+        if (! attr_inited) {
+            pthread_attr_init(&attr);
+            attr_inited = 1;
+        }
 
-	MUTEX_LOCK(&create_destruct_mutex);
-	thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
-	if (!thread) {	
-	    MUTEX_UNLOCK(&create_destruct_mutex);
-	    PerlLIO_write(PerlIO_fileno(Perl_error_log),
-			  PL_no_mem, strlen(PL_no_mem));
-	    my_exit(1);
-	}
-	Zero(thread,1,ithread);
-	thread->next = threads;
-	thread->prev = threads->prev;
-	threads->prev = thread;
-	thread->prev->next = thread;
-	/* Set count to 1 immediately in case thread exits before
-	 * we return to caller !
-	 */
-	thread->count = 1;
-	MUTEX_INIT(&thread->mutex);
-	thread->tid = tid_counter++;
-	thread->gimme = GIMME_V;
-
-	/* "Clone" our interpreter into the thread's interpreter
-	 * This gives thread access to "static data" and code.
-	 */
-
-	PerlIO_flush((PerlIO*)NULL);
-	Perl_ithread_set(aTHX_ thread);
-
-	SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
-	                              value */
-	PL_srand_called = FALSE; /* Set it to false so we can detect
-	                            if it gets set during the clone */
-
-#ifdef WIN32
-	thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
-#else
-	thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
-#endif
-	/* perl_clone leaves us in new interpreter's context.
-	   As it is tricky to spot an implicit aTHX, create a new scope
-	   with aTHX matching the context for the duration of
-	   our work for new interpreter.
-	 */
-	{
-	    dTHXa(thread->interp);
-
-	    MY_CXT_CLONE;
-
-            /* Here we remove END blocks since they should only run
-	       in the thread they are created
-            */
-            SvREFCNT_dec(PL_endav);
-            PL_endav = newAV();
-            clone_param.flags = 0;
-	    thread->init_function = sv_dup(init_function, &clone_param);
-	    if (SvREFCNT(thread->init_function) == 0) {
-		SvREFCNT_inc(thread->init_function);
-	    }
-	    
-
-
-	    thread->params = sv_dup(params, &clone_param);
-	    SvREFCNT_inc(thread->params);
-
-
-	    /* The code below checks that anything living on
-	       the tmps stack and has been cloned (so it lives in the
-	       ptr_table) has a refcount higher than 0
-
-	       If the refcount is 0 it means that a something on the
-	       stack/context was holding a reference to it and
-	       since we init_stacks() in perl_clone that won't get
-	       cleaned and we will get a leaked scalar.
-	       The reason it was cloned was that it lived on the
-	       @_ stack.
-
-	       Example of this can be found in bugreport 15837
-	       where calls in the parameter list end up as a temp
-
-	       One could argue that this fix should be in perl_clone
-	    */
-	       
-
-	    while (tmps_ix > 0) { 
-	      SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
-	      tmps_ix--;
-	      if (sv && SvREFCNT(sv) == 0) {
-		SvREFCNT_inc(sv);
-		SvREFCNT_dec(sv);
-	      }
-	    }
-	    
-
-
-	    SvTEMP_off(thread->init_function);
-	    ptr_table_free(PL_ptr_table);
-	    PL_ptr_table = NULL;
-	    PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
-	}
-	Perl_ithread_set(aTHX_ current_thread);
-	PERL_SET_CONTEXT(aTHX);
-
-	/* Start the thread */
-
-#ifdef WIN32
-	thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
-			(LPVOID)thread, 0, &thread->thr);
-#else
-	{
-	  static pthread_attr_t attr;
-	  static int attr_inited = 0;
-	  static int attr_joinable = PTHREAD_CREATE_JOINABLE;
-	  if (!attr_inited) {
-	    attr_inited = 1;
-	    pthread_attr_init(&attr);
-	  }
+        /* Threads start out joinable */
 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
-            PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
-#  endif
-#  ifdef THREAD_CREATE_NEEDS_STACK
-	    if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
-	      panic = "panic: pthread_attr_setstacksize failed";
+        PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
 #  endif
 
-#ifdef OLD_PTHREADS_API
-	    failure
-	      = panic ? 1 : pthread_create( &thread->thr, attr,
-					    Perl_ithread_run, (void *)thread);
-#else
-#  if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
-	  pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
+        /* Set thread's stack size */
+        if ((thread->stack_size > 0) &&
+            pthread_attr_setstacksize(&attr, thread->stack_size))
+        {
+            panic = "PANIC: pthread_attr_setstacksize failed";
+        }
+
+        /* Create the thread */
+#  ifdef OLD_PTHREADS_API
+        failure = (panic) ? 1 : pthread_create(&thread->thr,
+                                               attr,
+                                               Perl_ithread_run,
+                                               (void *)thread);
+#  else
+#    if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
+        pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
+#    endif
+        failure = (panic) ? 1 : pthread_create(&thread->thr,
+                                               &attr,
+                                               Perl_ithread_run,
+                                               (void *)thread);
 #  endif
-	  failure
-	    = panic ? 1 : pthread_create( &thread->thr, &attr,
-					  Perl_ithread_run, (void *)thread);
-#endif
-	}
+    }
 #endif
-	known_threads++;
-	if (
+
+    /* Check for error */
 #ifdef WIN32
-	    thread->handle == NULL
+    if (thread->handle == NULL) {
 #else
-	    failure
+    if (failure) {
 #endif
-	    ) {
-	  MUTEX_UNLOCK(&create_destruct_mutex);
-	  sv_2mortal(params);
-	  Perl_ithread_destruct(aTHX_ thread, "create failed");
+        MUTEX_UNLOCK(&create_destruct_mutex);
+        sv_2mortal(params);
+        Perl_ithread_destruct(aTHX_ thread);
 #ifndef WIN32
-	  if (panic)
-	    Perl_croak(aTHX_ panic);
+        if (panic)
+            Perl_croak(aTHX_ panic);
 #endif
-	  return &PL_sv_undef;
-	}
-	active_threads++;
-	MUTEX_UNLOCK(&create_destruct_mutex);
-	sv_2mortal(params);
+        return (&PL_sv_undef);
+    }
 
-	return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
-}
+    active_threads++;
+    MUTEX_UNLOCK(&create_destruct_mutex);
 
-SV*
-Perl_ithread_self (pTHX_ SV *obj, char* Class)
-{
-   ithread *thread = Perl_ithread_get(aTHX);
-   if (thread)
-	return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
-   else
-	Perl_croak(aTHX_ "panic: cannot find thread data");
-   return NULL; /* silence compiler warning */
+    sv_2mortal(params);
+
+    return (ithread_to_SV(aTHX_ obj, thread, classname, FALSE));
 }
 
-/*
- * Joins the thread this code needs to take the returnvalue from the
- * call_sv and send it back
- */
 
-void
-Perl_ithread_CLONE(pTHX_ SV *obj)
+/* Return the current thread's object */
+static SV *
+Perl_ithread_self(pTHX_ SV *obj, char* classname)
 {
-    if (SvROK(obj)) {
-	ithread *thread = SV_to_ithread(aTHX_ obj);
-    }
-    else if (ckWARN_d(WARN_THREADS)) {
-	Perl_warn(aTHX_ "CLONE %" SVf,obj);
-    }
+    ithread *thread = Perl_ithread_get(aTHX);
+    return (ithread_to_SV(aTHX_ obj, thread, classname, TRUE));
 }
 
-AV*
+
+/* Joins the thread.
+ * This code takes the return value from the call_sv and sends it back.
+ */
+static AV *
 Perl_ithread_join(pTHX_ SV *obj)
 {
     ithread *thread = SV_to_ithread(aTHX_ obj);
+    int join_err;
+    AV *retparam;
+#ifdef WIN32
+    DWORD waitcode;
+#else
+    void *retval;
+#endif
+
     MUTEX_LOCK(&thread->mutex);
-    if (thread->state & PERL_ITHR_DETACHED) {
-	MUTEX_UNLOCK(&thread->mutex);
-	Perl_croak(aTHX_ "Cannot join a detached thread");
-    }
-    else if (thread->state & PERL_ITHR_JOINED) {
-	MUTEX_UNLOCK(&thread->mutex);
-	Perl_croak(aTHX_ "Thread already joined");
-    }
-    else {
-        AV* retparam;
-#ifdef WIN32
-	DWORD waitcode;
-#else
-	void *retval;
-#endif
-	MUTEX_UNLOCK(&thread->mutex);
-#ifdef WIN32
-	waitcode = WaitForSingleObject(thread->handle, INFINITE);
-	CloseHandle(thread->handle);
-	thread->handle = 0;
-#else
-	pthread_join(thread->thr,&retval);
-#endif
-	MUTEX_LOCK(&thread->mutex);
-	
-	/* sv_dup over the args */
-	{
-	  ithread*        current_thread;
-	  AV* params = (AV*) SvRV(thread->params);	
-	  PerlInterpreter *other_perl = thread->interp;
-	  CLONE_PARAMS clone_params;
-	  clone_params.stashes = newAV();
-	  clone_params.flags = CLONEf_JOIN_IN;
-	  PL_ptr_table = ptr_table_new();
-	  current_thread = Perl_ithread_get(aTHX);
-	  Perl_ithread_set(aTHX_ thread);
-	  /* ensure 'meaningful' addresses retain their meaning */
-	  ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
-	  ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
-	  ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
-
-#if 0
-	  {
-	    I32 len = av_len(params)+1;
-	    I32 i;
-	    for(i = 0; i < len; i++) {
-	      sv_dump(SvRV(AvARRAY(params)[i]));
-	    }
-	  }
-#endif
-	  retparam = (AV*) sv_dup((SV*)params, &clone_params);
-#if 0
-	  {
-	    I32 len = av_len(retparam)+1;
-	    I32 i;
-	    for(i = 0; i < len; i++) {
-		sv_dump(SvRV(AvARRAY(retparam)[i]));
-	    }
-	  }
-#endif
-	  Perl_ithread_set(aTHX_ current_thread);
-	  SvREFCNT_dec(clone_params.stashes);
-	  SvREFCNT_inc(retparam);
-	  ptr_table_free(PL_ptr_table);
-	  PL_ptr_table = NULL;
-
-	}
-	/* We are finished with it */
-	thread->state |= PERL_ITHR_JOINED;
-	S_ithread_clear(aTHX_ thread);
-	MUTEX_UNLOCK(&thread->mutex);
-    	
-	return retparam;
+    join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
+    MUTEX_UNLOCK(&thread->mutex);
+
+    if (join_err) {
+        if (join_err & PERL_ITHR_DETACHED) {
+            Perl_croak(aTHX_ "Cannot join a detached thread");
+        } else {
+            Perl_croak(aTHX_ "Thread already joined");
+        }
     }
-    return (AV*)NULL;
+
+#ifdef WIN32
+    waitcode = WaitForSingleObject(thread->handle, INFINITE);
+#else
+    pthread_join(thread->thr, &retval);
+#endif
+
+    MUTEX_LOCK(&thread->mutex);
+
+    /* sv_dup over the args */
+    {
+        AV *params;
+        PerlInterpreter *other_perl;
+        CLONE_PARAMS clone_params;
+        ithread *current_thread;
+
+        params = (AV *)SvRV(thread->params);
+        other_perl = thread->interp;
+        clone_params.stashes = newAV();
+        clone_params.flags = CLONEf_JOIN_IN;
+        PL_ptr_table = ptr_table_new();
+        current_thread = Perl_ithread_get(aTHX);
+        Perl_ithread_set(aTHX_ thread);
+        /* Ensure 'meaningful' addresses retain their meaning */
+        ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
+        ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
+        ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
+        retparam = (AV *)sv_dup((SV*)params, &clone_params);
+        Perl_ithread_set(aTHX_ current_thread);
+        SvREFCNT_dec(clone_params.stashes);
+        SvREFCNT_inc(retparam);
+        ptr_table_free(PL_ptr_table);
+        PL_ptr_table = NULL;
+    }
+
+    /* We are finished with it */
+    thread->state |= PERL_ITHR_JOINED;
+    S_ithread_clear(aTHX_ thread);
+    MUTEX_UNLOCK(&thread->mutex);
+
+    return (retparam);
 }
 
-void
+
+static void
 Perl_ithread_DESTROY(pTHX_ SV *sv)
 {
     ithread *thread = SV_to_ithread(aTHX_ sv);
-    sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
+    sv_unmagic(SvRV(sv), PERL_MAGIC_shared_scalar);
 }
 
 #endif /* USE_ITHREADS */
 
-MODULE = threads		PACKAGE = threads	PREFIX = ithread_
+MODULE = threads    PACKAGE = threads    PREFIX = ithread_
 PROTOTYPES: DISABLE
 
 #ifdef USE_ITHREADS
 
 void
-ithread_new (classname, function_to_call, ...)
-char *	classname
-SV *	function_to_call
-CODE:
-{
-    AV* params = newAV();
-    if (items > 2) {
-	int i;
-	for(i = 2; i < items ; i++) {
-	    av_push(params, SvREFCNT_inc(ST(i)));
-	}
-    }
-    ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
-    XSRETURN(1);
-}
+ithread_create(...)
+    PREINIT:
+        char *classname;
+        ithread *thread;
+        SV *function_to_call;
+        AV *params;
+        HV *specs;
+        UV stack_size;
+        int idx;
+        int ii;
+    CODE:
+        if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
+            if (--items < 2)
+                Perl_croak(aTHX_ "Usage: threads->create(\\%specs, function, ...)");
+            specs = (HV*)SvRV(ST(1));
+            idx = 1;
+        } else {
+            if (items < 2)
+                Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
+            specs = NULL;
+            idx = 0;
+        }
+
+        if (sv_isobject(ST(0))) {
+            /* $thr->create() */
+            classname = HvNAME(SvSTASH(SvRV(ST(0))));
+            thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
+            stack_size = thread->stack_size;
+        } else {
+            /* threads->create() */
+            classname = (char *)SvPV_nolen(ST(0));
+            stack_size = default_stack_size;
+        }
+
+        function_to_call = ST(idx+1);
+
+        if (specs) {
+            /* stack_size */
+            if (hv_exists(specs, "stack", 5)) {
+                stack_size = SvUV(*hv_fetch(specs, "stack", 5, 0));
+            } else if (hv_exists(specs, "stacksize", 9)) {
+                stack_size = SvUV(*hv_fetch(specs, "stacksize", 9, 0));
+            } else if (hv_exists(specs, "stack_size", 10)) {
+                stack_size = SvUV(*hv_fetch(specs, "stack_size", 10, 0));
+            }
+        }
+
+        /* Function args */
+        params = newAV();
+        if (items > 2) {
+            for (ii=2; ii < items ; ii++) {
+                av_push(params, SvREFCNT_inc(ST(idx+ii)));
+            }
+        }
+
+        /* Create thread */
+        ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv,
+                                               classname,
+                                               function_to_call,
+                                               stack_size,
+                                               newRV_noinc((SV*)params)));
+        /* XSRETURN(1); - implied */
+
 
 void
-ithread_list(char *classname)
-PPCODE:
-{
-  ithread *curr_thread;
-  MUTEX_LOCK(&create_destruct_mutex);
-  curr_thread = threads;
-  if(curr_thread->tid != 0)	
-    XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
-  while(curr_thread) {
-    curr_thread = curr_thread->next;
-    if(curr_thread == threads)
-      break;
-    if(curr_thread->state & PERL_ITHR_DETACHED ||
-       curr_thread->state & PERL_ITHR_JOINED)
-         continue;
-     XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
-  }	
-  MUTEX_UNLOCK(&create_destruct_mutex);
-}
+ithread_self(...)
+    PREINIT:
+        char *classname;
+    CODE:
+        /* Class method only */
+        if (SvROK(ST(0)))
+            Perl_croak(aTHX_ "Usage: threads->self()");
+        classname = (char *)SvPV_nolen(ST(0));
+
+        ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv, classname));
+        /* XSRETURN(1); - implied */
 
 
 void
-ithread_self(char *classname)
-CODE:
-{
-	ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
-	XSRETURN(1);
-}
+ithread_tid(...)
+    PREINIT:
+        ithread *thread;
+    CODE:
+        thread = SV_to_ithread(aTHX_ ST(0));
+        ST(0) = sv_2mortal(newSVuv(thread->tid));
+        /* XSRETURN(1); - implied */
 
-int
-ithread_tid(ithread *thread)
 
 void
-ithread_join(SV *obj)
-PPCODE:
-{
-  AV* params = Perl_ithread_join(aTHX_ obj);
-  int i;
-  I32 len = AvFILL(params);
-  for (i = 0; i <= len; i++) {
-    SV* tmp = av_shift(params);
-    XPUSHs(tmp);
-    sv_2mortal(tmp);
-  }
-  SvREFCNT_dec(params);
-}
+ithread__handle(...);
+    PREINIT:
+        ithread *thread;
+    CODE:
+        thread = SV_to_ithread(aTHX_ ST(0));
+#ifdef WIN32
+        ST(0) = sv_2mortal(newSVuv(PTR2UV(thread->handle)));
+#else
+        ST(0) = sv_2mortal(newSVuv(PTR2UV(thread->thr)));
+#endif
+        /* XSRETURN(1); - implied */
+
 
 void
-yield(...)
-CODE:
-{
-    YIELD;
-}
-	
+ithread_join(...)
+    PREINIT:
+        AV *params;
+        IV len;
+        int i;
+    PPCODE:
+        /* Object method only */
+        if (! sv_isobject(ST(0)))
+            Perl_croak(aTHX_ "Usage: $thr->join()");
+
+        /* Join thread and get return values */
+        params = Perl_ithread_join(aTHX_ ST(0));
+        if (! params) {
+            XSRETURN_UNDEF;
+        }
+        len = AvFILL(params);
+        /* Put return values on stack */
+        for (i=0; i <= len; i++) {
+            SV* tmp = av_shift(params);
+            XPUSHs(tmp);
+            sv_2mortal(tmp);
+        }
+        /* Free return value array */
+        SvREFCNT_dec(params);
+
+
+void
+ithread_detach(...)
+    PREINIT:
+        ithread *thread;
+    CODE:
+        thread = SV_to_ithread(aTHX_ ST(0));
+        Perl_ithread_detach(aTHX_ thread);
+
+
+void
+ithread_DESTROY(...)
+    CODE:
+        Perl_ithread_DESTROY(aTHX_ ST(0));
+
+
+void
+ithread_list(...)
+    PREINIT:
+        char *classname;
+        ithread *thr;
+        int list_context;
+        IV count = 0;
+    PPCODE:
+        /* Class method only */
+        if (SvROK(ST(0)))
+            Perl_croak(aTHX_ "Usage: threads->list()");
+        classname = (char *)SvPV_nolen(ST(0));
+
+        /* Calling context */
+        list_context = (GIMME_V == G_ARRAY);
+
+        /* Walk through threads list */
+        MUTEX_LOCK(&create_destruct_mutex);
+        for (thr = threads->next;
+             thr != threads;
+             thr = thr->next)
+        {
+            /* Ignore detached or joined threads */
+            if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
+                continue;
+            }
+            /* Push object on stack if list context */
+            if (list_context) {
+                XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)));
+            }
+            count++;
+        }
+        MUTEX_UNLOCK(&create_destruct_mutex);
+        /* If scalar context, send back count */
+        if (! list_context) {
+            ST(0) = sv_2mortal(newSViv(count));
+            XSRETURN(1);
+        }
+
+
+void
+ithread_object(...)
+    PREINIT:
+        char *classname;
+        UV tid;
+        ithread *thr;
+        int found = 0;
+    CODE:
+        /* Class method only */
+        if (SvROK(ST(0)))
+            Perl_croak(aTHX_ "Usage: threads->object($tid)");
+        classname = (char *)SvPV_nolen(ST(0));
+
+        if ((items < 2) || ! SvOK(ST(1))) {
+            XSRETURN_UNDEF;
+        }
+
+        tid = (UV)SvUV(ST(1));
+
+        /* Walk through threads list */
+        MUTEX_LOCK(&create_destruct_mutex);
+        for (thr = threads->next;
+             thr != threads;
+             thr = thr->next)
+        {
+            /* Look for TID, but ignore detached or joined threads */
+            if ((thr->tid != tid) ||
+                (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
+            {
+                continue;
+            }
+            /* Put object on stack */
+            ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
+            found = 1;
+            break;
+        }
+        MUTEX_UNLOCK(&create_destruct_mutex);
+        if (! found) {
+            XSRETURN_UNDEF;
+        }
+        /* XSRETURN(1); - implied */
+
+
+void
+ithread_get_stack_size(...)
+    PREINIT:
+        UV stack_size;
+    CODE:
+        if (sv_isobject(ST(0))) {
+            /* $thr->get_stack_size() */
+            ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
+            stack_size = thread->stack_size;
+        } else {
+            /* threads->get_stack_size() */
+            stack_size = default_stack_size;
+        }
+        ST(0) = sv_2mortal(newSVuv(stack_size));
+        /* XSRETURN(1); - implied */
+
+
+void
+ithread_set_stack_size(...)
+    PREINIT:
+        UV old_size;
+    CODE:
+        if (items != 2)
+            Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)");
+        if (sv_isobject(ST(0)))
+            Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
+
+        old_size = default_stack_size;
+        default_stack_size = SvUV(ST(1));
+        ST(0) = sv_2mortal(newSVuv(old_size));
+        /* XSRETURN(1); - implied */
+
 
 void
-ithread_detach(ithread *thread)
+ithread_yield(...)
+    CODE:
+        YIELD;
+
 
 void
-ithread_DESTROY(SV *thread)
+ithread_equal(...)
+    CODE:
+        if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
+            ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
+            ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
+            ST(0) = (thr1->tid == thr2->tid) ? &PL_sv_yes : &PL_sv_no;
+        } else {
+            ST(0) = &PL_sv_no;
+        }
+        /* XSRETURN(1); - implied */
 
 #endif /* USE_ITHREADS */
 
 BOOT:
 {
 #ifdef USE_ITHREADS
-        MY_CXT_INIT;
-	ithread* thread;
-	PL_perl_destruct_level = 2;
-	MUTEX_INIT(&create_destruct_mutex);
-	MUTEX_LOCK(&create_destruct_mutex);
-	PL_threadhook = &Perl_ithread_hook;
-	thread  = (ithread *) PerlMemShared_malloc(sizeof(ithread));
-	if (!thread) {
-	    PerlLIO_write(PerlIO_fileno(Perl_error_log),
-			  PL_no_mem, strlen(PL_no_mem));
-	    my_exit(1);
-	}
-	Zero(thread,1,ithread);
-	PL_perl_destruct_level = 2;
-	MUTEX_INIT(&thread->mutex);
-	threads = thread;
-	thread->next = thread;
-        thread->prev = thread;
-	thread->interp = aTHX;
-	thread->count  = 1;  /* Immortal. */
-	thread->tid = tid_counter++;
-	known_threads++;
-	active_threads++;
-	thread->state = PERL_ITHR_DETACHED;
-#ifdef WIN32
-	thread->thr = GetCurrentThreadId();
-#else
-	thread->thr = pthread_self();
-#endif
+    /* The 'main' thread is thread 0.
+     * It is detached (unjoinable) and immortal.
+     */
+
+    ithread *thread;
+    MY_CXT_INIT;
 
-	Perl_ithread_set(aTHX_ thread);
-	MUTEX_UNLOCK(&create_destruct_mutex);
+    PL_perl_destruct_level = 2;
+    MUTEX_INIT(&create_destruct_mutex);
+    MUTEX_LOCK(&create_destruct_mutex);
+
+    PL_threadhook = &Perl_ithread_hook;
+
+    thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
+    if (! thread) {
+        PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
+        my_exit(1);
+    }
+    Zero(thread, 1, ithread);
+
+    PL_perl_destruct_level = 2;
+    MUTEX_INIT(&thread->mutex);
+
+    thread->tid = tid_counter++;        /* Thread 0 */
+
+    /* Head of the threads list */
+    threads = thread;
+    thread->next = thread;
+    thread->prev = thread;
+
+    thread->count = 1;                  /* Immortal */
+
+    thread->interp = aTHX;
+    thread->free_interp = aTHX;
+    thread->state = PERL_ITHR_DETACHED; /* Detached */
+    thread->stack_size = default_stack_size;
+#  ifdef WIN32
+    thread->thr = GetCurrentThreadId();
+#  else
+    thread->thr = pthread_self();
+#  endif
+
+    active_threads++;
+
+    Perl_ithread_set(aTHX_ thread);
+    MUTEX_UNLOCK(&create_destruct_mutex);
 #endif /* USE_ITHREADS */
 }
-

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About