-threads version 1.18
+threads version 1.24
====================
This module needs perl 5.8.0 or later compiled with 'useithreads'.
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
use ExtUtils::testlib;
-BEGIN { $| = 1; print "1..32\n" };
-use threads;
+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..32\n"); ### Number of tests that will be run ###
+};
+
+use threads;
if ($threads::VERSION && ! exists($ENV{'PERL_CORE'})) {
print(STDERR "# Testing threads $threads::VERSION\n");
### Start of Testing ###
-
-
-sub ok {
- my ($id, $ok, $name) = @_;
-
- # You have to do it this way or VMS will get confused.
- print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
-
- printf "# Failed test at line %d\n", (caller)[2] unless $ok;
-
- return $ok;
-}
-
+ok(2, 1 == $threads::threads, "Check that threads::threads is true");
sub test1 {
- ok(2,'bar' eq $_[0],"Test that argument passing works");
+ ok(3,'bar' eq $_[0], "Test that argument passing works");
}
-threads->create('test1','bar')->join();
+threads->create('test1', 'bar')->join();
sub test2 {
- ok(3,'bar' eq $_[0]->[0]->{foo},"Test that passing arguments as references work");
+ ok(4,'bar' eq $_[0]->[0]->{'foo'}, "Test that passing arguments as references work");
}
+threads->create(\&test2, [{'foo' => 'bar'}])->join();
-threads->create(\&test2,[{foo => 'bar'}])->join();
-
-
-#test execuion of normal sub
-sub test3 { ok(4,shift() == 1,"Test a normal sub") }
-threads->create(\&test3,1)->join();
-
-
-#check Config
-ok(5, 1 == $threads::threads,"Check that threads::threads is true");
-
-#test trying to detach thread
+sub 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();
}
use strict;
use warnings;
-# test that END blocks are run in the thread that created them and
-# not in any child threads
-
BEGIN {
if ($ENV{'PERL_CORE'}){
chdir 't';
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
use ExtUtils::testlib;
-BEGIN { print "1..6\n" };
use threads;
use threads::shared;
-my $test_id = 1;
-share($test_id);
+BEGIN {
+ $| = 1;
+ print("1..6\n"); ### Number of tests that will be run ###
+};
+
+my $TEST = 1;
+share($TEST);
+
+ok(1, 'Loaded');
sub ok {
my ($ok, $name) = @_;
- lock($test_id);
+ lock($TEST);
+ my $id = $TEST++;
# 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);
}
-ok(1,'Loaded');
-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();
+
+
+### Start of Testing ###
+
+# Test that END blocks are run in the thread that created them,
+# and not in any child threads.
+
+END {
+ ok(1, 'Main END block')
+}
+
+threads->create(sub { eval "END { ok(1, '1st thread END block') }"})->join();
+threads->create(sub { eval "END { ok(1, '2nd thread END block') }"})->join();
sub thread {
- eval "END { ok(1,'') }";
- threads->create(sub { eval "END { ok(1,'') }"})->join();
+ eval "END { ok(1, '4th thread END block') }";
+ threads->create(sub { eval "END { ok(1, '5th thread END block') }"})->join();
}
+threads->create(\&thread)->join();
+
+# EOF
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
use ExtUtils::testlib;
-BEGIN { print "1..17\n" };
use threads;
use threads::shared;
-my $test_id = 1;
-share($test_id);
+BEGIN {
+ $| = 1;
+ print("1..17\n"); ### Number of tests that will be run ###
+};
+
+my $TEST = 1;
+share($TEST);
+
+ok(1, 'Loaded');
sub ok {
my ($ok, $name) = @_;
- lock $test_id; # make print and increment atomic
+ lock($TEST);
+ my $id = $TEST++;
# 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: @_");
+ ok(1, '# Skipped: ' . $_[0]);
}
-ok(1,"");
+### Start of Testing ###
{
my $retval = threads->create(sub { return ("hi") })->join();
}
{
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");
print $retval "test2\n";
-# seek($retval,0,0);
-# ok(<$retval> eq "test\n");
close($retval);
unlink("threadtest");
}
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,"");
}
# 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->create( 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->create(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($sawpid && $sawexe, 'altering $0 is effective');
+ } else {
+ skip("\$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("\$0 check: opening 'ps -f |' failed: $!");
}
- } else {
- skip("\$0 check: opening 'ps -f |' failed: $!");
- }
} else {
- skip("\$0 check: only on Linux");
+ skip("\$0 check: only on Linux");
}
{
}
{
- # 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".
+ # The "use IO::File" is not actually used for anything; its only purpose
+ # is 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
+ # This coredumped between #20930 and #21000
$_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2;
}
+# EOF
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
return ($ok);
}
-BEGIN { $| = 1; print "1..12\n"};
+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 = 2;
share($mutex);
+
sub localtime_r {
- lock($mutex);
- my $retval = localtime(shift());
- 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);
- ok($mutex, ! $error, 'localtime safe');
- $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
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
use ExtUtils::testlib;
-
-
-BEGIN { $| = 1; print "1..15\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..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');
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
use Hash::Util 'lock_keys';
-# Note that we can't use Test::More here, as we would need to
-# call is() from within the DESTROY() function at global destruction time,
-# and parts of Test::* may have already been freed by then
+my $test :shared = 2;
-my $test : shared = 2;
-
-sub is($$$) {
+# 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
+sub is($$$)
+{
my ($got, $want, $desc) = @_;
lock($test);
- 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
-#
-#########################
+# This tests for too much destruction which was caused by cloning stashes
+# on join which led to double the dataspace under 5.8.0
if ($] != 5.008)
-{
- 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" )
+{
+ 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;
+
+ 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.
-#
-#########################
+# disallow that to be done because an attempt was made to change a variable
+# with the :unique attribute.
+
{
lock($test);
if ($] == 5.008 || $] >= 5.008003) {
$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->create(
- sub {
+threads->create(sub {
lock($test);
- 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++;
+ 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/
} else {
print("ok $test # Skip $TODO - unique_hash\n");
}
- $test++;
- }
-)->join;
+ $test++;
+ })->join;
# bugid #24940 :unique should fail on my and sub declarations
# 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->create(sub { return scalar keys %h })->join;
-is ($child, 2, "keys correct in child");
+my $child = threads->create(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->create(sub { return scalar keys %h })->join;
-is ($child, 1, "keys correct in child with restricted hash");
+$child = threads->create(sub { return (scalar(keys(%h))); })->join;
+is($child, 1, "keys correct in child with restricted hash");
-1;
+# EOF
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
use ExtUtils::testlib;
-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
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
use ExtUtils::testlib;
-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
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
}
use ExtUtils::testlib;
-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
unshift @INC, '../lib';
}
use Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
use ExtUtils::testlib;
-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;
my $lock : shared;
my $t;
{
- lock($lock);
- $t = threads->create(sub { lock($lock); print "ok 5\n"});
- print "ok 4\n";
+ lock($lock);
+ $t = threads->create(sub { lock($lock); print "ok 5\n"});
+ print "ok 4\n";
}
$t->join();
}
my $ret;
print $val;
if(@_) {
- $ret = threads->create(\&dorecurse, @_);
- $ret->join;
+ $ret = threads->create(\&dorecurse, @_);
+ $ret->join;
}
}
{
{
my $lock : shared;
sub islocked {
- lock($lock);
- my $val = shift;
- my $ret;
- print $val;
- if (@_) {
- $ret = threads->create(\&islocked, shift);
- }
- return $ret;
+ lock($lock);
+ my $val = shift;
+ my $ret;
+ print $val;
+ if (@_) {
+ $ret = threads->create(\&islocked, shift);
+ }
+ return $ret;
}
my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n");
$t->join->join;
}
{
# 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->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
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->create( \&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->create( \&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");
use strict;
use warnings;
-our $VERSION = '1.24_01';
+our $VERSION = '1.24_02';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
}
}
+
# Load the XS code
require XSLoader;
XSLoader::load('threads', $XS_VERSION);
=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.
+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.
+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.
+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 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.
+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 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
=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 Returning closures from threads
#ifdef USE_ITHREADS
-
#ifdef WIN32
-#include <windows.h>
-#include <win32thread.h>
+# include <windows.h>
+# 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_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 */
- UV tid; /* Threads module's thread id */
- perl_mutex mutex; /* Mutex for updating things in this struct */
+#define PERL_ITHR_JOINABLE 0
+#define PERL_ITHR_DETACHED 1
+#define PERL_ITHR_JOINED 2
+#define PERL_ITHR_FINISHED 4
+
+typedef struct _ithread {
+ struct _ithread *next; /* Next thread in the list */
+ struct _ithread *prev; /* Prev thread in the list */
+ PerlInterpreter *interp; /* The threads interpreter */
+ UV tid; /* Threads module's thread id */
+ perl_mutex mutex; /* Mutex for updating things in this struct */
int count; /* How many SVs have a reference to us */
- int state; /* Are we detached ? */
- int gimme; /* Context of create */
- SV* init_function; /* Code to run */
- SV* params; /* Args to pass function */
+ 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
} ithread;
+
+/* Used by Perl interpreter for thread context switching */
#define MY_CXT_KEY "threads::_guts" XS_VERSION
typedef struct {
START_MY_CXT
+/* Linked list of all threads */
static ithread *threads;
-static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
+/* Protects the creation and destruction of threads*/
+static perl_mutex create_destruct_mutex;
static UV tid_counter = 0;
static IV active_threads = 0;
+/* Used by Perl interpreter for thread context switching */
static void
-S_ithread_set (pTHX_ ithread* thread)
+S_ithread_set(pTHX_ ithread *thread)
{
dMY_CXT;
MY_CXT.thread = thread;
}
-static ithread*
-S_ithread_get (pTHX) {
+static ithread *
+S_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|PERL_ITHR_JOINED));
interp = thread->interp;
if (interp) {
- dTHXa(interp);
+ dTHXa(interp);
+
+ PERL_SET_CONTEXT(interp);
+ S_ithread_set(aTHX_ thread);
- PERL_SET_CONTEXT(interp);
- S_ithread_set(aTHX_ thread);
-
- SvREFCNT_dec(thread->params);
+ SvREFCNT_dec(thread->params);
+ thread->params = Nullsv;
- thread->params = Nullsv;
- perl_destruct(interp);
- thread->interp = NULL;
+ perl_destruct(interp);
+ thread->interp = NULL;
}
if (interp)
- perl_free(interp);
+ perl_free(interp);
+
PERL_SET_CONTEXT(aTHX);
}
-/*
- * free an ithread structure and any attached data if its count == 0
- */
+/* Free an ithread structure and any attached data if its count == 0 */
static void
-S_ithread_destruct (pTHX_ ithread* thread)
+S_ithread_destruct(pTHX_ ithread *thread)
{
#ifdef WIN32
- HANDLE handle;
+ HANDLE handle;
#endif
- MUTEX_LOCK(&thread->mutex);
-
- /* Thread is still in use */
- if (thread->count != 0) {
- MUTEX_UNLOCK(&thread->mutex);
- return;
- }
+ MUTEX_LOCK(&thread->mutex);
- MUTEX_LOCK(&create_destruct_mutex);
- /* Main thread (0) is immortal and should never get here */
- assert(thread->tid != 0);
+ /* Thread is still in use */
+ if (thread->count != 0) {
+ MUTEX_UNLOCK(&thread->mutex);
+ return;
+ }
- /* Remove from circular list of threads */
- thread->next->prev = thread->prev;
- thread->prev->next = thread->next;
- thread->next = NULL;
- thread->prev = NULL;
- MUTEX_UNLOCK(&create_destruct_mutex);
+ MUTEX_LOCK(&create_destruct_mutex);
+ /* Main thread (0) is immortal and should never get here */
+ assert(thread->tid != 0);
+
+ /* Remove from circular list of threads */
+ thread->next->prev = thread->prev;
+ thread->prev->next = thread->next;
+ thread->next = NULL;
+ thread->prev = NULL;
+ MUTEX_UNLOCK(&create_destruct_mutex);
- /* Thread is now disowned */
- S_ithread_clear(aTHX_ thread);
+ /* Thread is now disowned */
+ S_ithread_clear(aTHX_ thread);
#ifdef WIN32
- handle = thread->handle;
- thread->handle = NULL;
+ handle = thread->handle;
+ thread->handle = NULL;
#endif
- MUTEX_UNLOCK(&thread->mutex);
- MUTEX_DESTROY(&thread->mutex);
+ MUTEX_UNLOCK(&thread->mutex);
+ MUTEX_DESTROY(&thread->mutex);
#ifdef WIN32
- if (handle)
- CloseHandle(handle);
+ if (handle)
+ CloseHandle(handle);
#endif
- /* Call PerlMemShared_free() in the context of the "first" interpreter
- * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
- */
- aTHX = PL_curinterp;
- PerlMemShared_free(thread);
+ /* Call PerlMemShared_free() in the context of the "first" interpreter
+ * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
+ */
+ aTHX = PL_curinterp;
+ PerlMemShared_free(thread);
}
+
+/* Called on exit */
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",
- active_threads);
- veto_cleanup = 1;
+ if ((aTHX == PL_curinterp) && (active_threads != 1)) {
+ if (ckWARN_d(WARN_THREADS)) {
+ Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", active_threads);
+ }
+ veto_cleanup = 1;
}
MUTEX_UNLOCK(&create_destruct_mutex);
- return veto_cleanup;
+ return (veto_cleanup);
}
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
if (cleanup)
S_ithread_destruct(aTHX_ thread);
- return 0;
+ 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
+/* Starts executing the thread.
+ * Passed as the C level function to run in the new thread.
*/
-
#ifdef WIN32
static THREAD_RET_TYPE
-S_ithread_run(LPVOID arg) {
+S_ithread_run(LPVOID arg)
#else
-static void*
-S_ithread_run(void * arg) {
+static void *
+S_ithread_run(void * arg)
#endif
- ithread* thread = (ithread*) arg;
- int cleanup;
+{
+ ithread *thread = (ithread *)arg;
+ int cleanup;
- dTHXa(thread->interp);
- PERL_SET_CONTEXT(thread->interp);
- S_ithread_set(aTHX_ thread);
+ dTHXa(thread->interp);
+ PERL_SET_CONTEXT(thread->interp);
+ S_ithread_set(aTHX_ thread);
#if 0
- /* Far from clear messing with ->thr child-side is a good idea */
- MUTEX_LOCK(&thread->mutex);
+ /* Far from clear messing with ->thr child-side is a good idea */
+ MUTEX_LOCK(&thread->mutex);
#ifdef WIN32
- thread->thr = GetCurrentThreadId();
+ thread->thr = GetCurrentThreadId();
#else
- thread->thr = pthread_self();
+ thread->thr = pthread_self();
#endif
- MUTEX_UNLOCK(&thread->mutex);
+ MUTEX_UNLOCK(&thread->mutex);
#endif
- PL_perl_destruct_level = 2;
-
- {
- AV* params = (AV*) SvRV(thread->params);
- int len = (int)av_len(params)+1;
- int ii;
- dSP;
- ENTER;
- SAVETMPS;
- PUSHMARK(SP);
- for(ii = 0; ii < len; ii++) {
- XPUSHs(av_shift(params));
- }
- PUTBACK;
- len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
-
- SPAGAIN;
- for (ii=len-1; ii >= 0; ii--) {
- SV *sv = POPs;
- av_store(params, ii, SvREFCNT_inc(sv));
- }
- if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
- Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
- }
- FREETMPS;
- LEAVE;
-
- /* Release function ref */
- SvREFCNT_dec(thread->init_function);
- thread->init_function = Nullsv;
- }
-
- 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);
+ PL_perl_destruct_level = 2;
- if (cleanup)
- S_ithread_destruct(aTHX_ thread);
+ {
+ AV *params = (AV *)SvRV(thread->params);
+ int len = (int)av_len(params)+1;
+ int ii;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+
+ /* Put args on the stack */
+ PUSHMARK(SP);
+ for (ii=0; ii < len; ii++) {
+ XPUSHs(av_shift(params));
+ }
+ PUTBACK;
+
+ /* Run the specified function */
+ len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
+
+ /* Remove args from stack and put back in params array */
+ SPAGAIN;
+ for (ii=len-1; ii >= 0; ii--) {
+ SV *sv = POPs;
+ av_store(params, ii, SvREFCNT_inc(sv));
+ }
+
+ /* Check for failure */
+ if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
+ Perl_warn(aTHX_ "Thread failed to start: %" SVf, ERRSV);
+ }
+
+ FREETMPS;
+ LEAVE;
+
+ /* Release function ref */
+ SvREFCNT_dec(thread->init_function);
+ thread->init_function = Nullsv;
+ }
- MUTEX_LOCK(&create_destruct_mutex);
- active_threads--;
- MUTEX_UNLOCK(&create_destruct_mutex);
+ 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)
+ S_ithread_destruct(aTHX_ thread);
+
+ MUTEX_LOCK(&create_destruct_mutex);
+ active_threads--;
+ MUTEX_UNLOCK(&create_destruct_mutex);
#ifdef WIN32
- return (DWORD)0;
+ return ((DWORD)0);
#else
- return 0;
+ return (0);
#endif
}
+
+/* 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);
+ MUTEX_LOCK(&thread->mutex);
+ thread->count++;
+ MUTEX_UNLOCK(&thread->mutex);
+ }
+
+ if (! obj) {
+ obj = newSV(0);
}
- 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);
+
+ 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);
}
static ithread *
SV_to_ithread(pTHX_ SV *sv)
{
- if (SvROK(sv))
- {
- return INT2PTR(ithread*, SvIV(SvRV(sv)));
- }
- else
- {
- return S_ithread_get(aTHX);
- }
+ /* Argument is a thread */
+ if (SvROK(sv)) {
+ return (INT2PTR(ithread *, SvIV(SvRV(sv))));
+ }
+ /* Argument is classname, therefore return current thread */
+ return (S_ithread_get(aTHX));
}
-/*
- * ithread->create(); ( aka ithread->new() )
- * Called in context of parent thread
- */
+/* threads->create()
+ * Called in context of parent thread.
+ */
static SV *
-S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
+S_ithread_create(
+ pTHX_ SV *obj,
+ char *classname,
+ SV *init_function,
+ SV *params)
{
- ithread* thread;
- CLONE_PARAMS clone_param;
- ithread* current_thread = S_ithread_get(aTHX);
+ ithread *thread;
+ CLONE_PARAMS clone_param;
+ ithread *current_thread = S_ithread_get(aTHX);
- SV** tmps_tmp = PL_tmps_stack;
- IV tmps_ix = PL_tmps_ix;
+ SV **tmps_tmp = PL_tmps_stack;
+ IV tmps_ix = PL_tmps_ix;
#ifndef WIN32
- int rc_stack_size = 0;
- int rc_thread_create = 0;
+ int rc_stack_size = 0;
+ int rc_thread_create = 0;
#endif
+ MUTEX_LOCK(&create_destruct_mutex);
+
+ /* Allocate thread structure */
+ 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;
- 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->gimme = GIMME_V;
-
- /* "Clone" our interpreter into the thread's interpreter
- * This gives thread access to "static data" and code.
- */
-
- PerlIO_flush((PerlIO*)NULL);
- S_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 */
+ /* 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);
+ S_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);
+ thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
#else
- thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
+ 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;
- }
- S_ithread_set(aTHX_ current_thread);
- PERL_SET_CONTEXT(aTHX);
-
- /* Start the thread */
+ /* 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;
+ }
+ S_ithread_set(aTHX_ current_thread);
+ PERL_SET_CONTEXT(aTHX);
+
+ /* Create/start the thread */
#ifdef WIN32
- thread->handle = CreateThread(NULL, 0, S_ithread_run,
- (LPVOID)thread, 0, &thread->thr);
+ thread->handle = CreateThread(NULL,
+ (DWORD)0,
+ S_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);
- }
+ {
+ 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;
+ }
+
# ifdef PTHREAD_ATTR_SETDETACHSTATE
- PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
+ /* Threads start out joinable */
+ PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
# endif
+
# ifdef THREAD_CREATE_NEEDS_STACK
- rc_stack_size = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK);
+ /* Set thread's stack size */
+ rc_stack_size = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK);
# endif
- if (! rc_stack_size) {
-#ifdef OLD_PTHREADS_API
- rc_thread_create = pthread_create( &thread->thr, attr,
- S_ithread_run, (void *)thread);
-#else
-# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
- pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
+ /* Create the thread */
+ if (! rc_stack_size) {
+# ifdef OLD_PTHREADS_API
+ rc_thread_create = pthread_create(&thread->thr,
+ attr,
+ S_ithread_run,
+ (void *)thread);
+# else
+# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
+ pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
+# endif
+ rc_thread_create = pthread_create(&thread->thr,
+ &attr,
+ S_ithread_run,
+ (void *)thread);
# endif
- rc_thread_create = pthread_create( &thread->thr, &attr,
- S_ithread_run, (void *)thread);
-#endif
- }
- }
+ }
+ }
#endif
- /* Check for errors */
+ /* Check for errors */
#ifdef WIN32
- if (thread->handle == NULL) {
+ if (thread->handle == NULL) {
#else
- if (rc_stack_size || rc_thread_create) {
+ if (rc_stack_size || rc_thread_create) {
#endif
- MUTEX_UNLOCK(&create_destruct_mutex);
- sv_2mortal(params);
- S_ithread_destruct(aTHX_ thread);
+ MUTEX_UNLOCK(&create_destruct_mutex);
+ sv_2mortal(params);
+ S_ithread_destruct(aTHX_ thread);
#ifndef WIN32
if (ckWARN_d(WARN_THREADS)) {
# ifdef THREAD_CREATE_NEEDS_STACK
Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
}
#endif
- return &PL_sv_undef;
- }
- active_threads++;
- MUTEX_UNLOCK(&create_destruct_mutex);
- sv_2mortal(params);
+ return (&PL_sv_undef);
+ }
+
+ active_threads++;
+ MUTEX_UNLOCK(&create_destruct_mutex);
+
+ sv_2mortal(params);
- return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
+ return (ithread_to_SV(aTHX_ obj, thread, classname, FALSE));
}
#endif /* USE_ITHREADS */
-MODULE = threads PACKAGE = threads PREFIX = ithread_
+MODULE = threads PACKAGE = threads PREFIX = ithread_
PROTOTYPES: DISABLE
#ifdef USE_ITHREADS
ithread_list(...)
PREINIT:
char *classname;
- ithread *thr;
+ ithread *thread;
int list_context;
IV count = 0;
PPCODE:
/* Walk through threads list */
MUTEX_LOCK(&create_destruct_mutex);
- for (thr = threads->next;
- thr != threads;
- thr = thr->next)
+ for (thread = threads->next;
+ thread != threads;
+ thread = thread->next)
{
/* Ignore detached or joined threads */
- if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
+ if (thread->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)));
+ XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
}
count++;
}
void
ithread_equal(...)
+ PREINIT:
+ int are_equal = 0;
CODE:
- /* Compares TIDs to determine thread equality.
- * Return 0 on false for backward compatibility.
- */
+ /* Compares TIDs to determine thread equality */
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))));
- if (thr1->tid == thr2->tid) {
- XST_mYES(0);
- } else {
- XST_mIV(0, 0);
- }
+ are_equal = (thr1->tid == thr2->tid);
+ }
+ if (are_equal) {
+ XST_mYES(0);
} else {
+ /* Return 0 on false for backward compatibility */
XST_mIV(0, 0);
}
/* XSRETURN(1); - implied */
PREINIT:
char *classname;
UV tid;
- ithread *thr;
+ ithread *thread;
int found = 0;
CODE:
/* Class method only */
XSRETURN_UNDEF;
}
+ /* threads->object($tid) */
tid = SvUV(ST(1));
/* Walk through threads list */
MUTEX_LOCK(&create_destruct_mutex);
- for (thr = threads->next;
- thr != threads;
- thr = thr->next)
+ for (thread = threads->next;
+ thread != threads;
+ thread = thread->next)
{
/* Look for TID, but ignore detached or joined threads */
- if ((thr->tid != tid) ||
- (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
+ if ((thread->tid != tid) ||
+ (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
{
continue;
}
/* Put object on stack */
- ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
+ ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
found = 1;
break;
}
#endif /* USE_ITHREADS */
+
BOOT:
{
#ifdef USE_ITHREADS
- /* The 'main' thread is thread 0.
- * It is detached (unjoinable) and immortal.
- */
- ithread* thread;
- MY_CXT_INIT;
-
- 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);
-
- /* Head of the threads list */
- threads = thread;
- thread->next = thread;
- thread->prev = thread;
-
- thread->interp = aTHX;
- thread->count = 1; /* Immortal. */
- thread->tid = tid_counter++;
- 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.
+ */
- S_ithread_set(aTHX_ thread);
- MUTEX_UNLOCK(&create_destruct_mutex);
+ ithread *thread;
+ MY_CXT_INIT;
+
+ 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->state = PERL_ITHR_DETACHED; /* Detached */
+# ifdef WIN32
+ thread->thr = GetCurrentThreadId();
+# else
+ thread->thr = pthread_self();
+# endif
+
+ active_threads++;
+
+ S_ithread_set(aTHX_ thread);
+ MUTEX_UNLOCK(&create_destruct_mutex);
#endif /* USE_ITHREADS */
}
-
projects / p5sagit/p5-mst-13.2.git / commitdiff