Revision history for Perl extension threads.
+1.62 Thu May 17 16:10:49 2007
+ - Fixed :all import option
+ - Fixed problems in test suite
+ - Subversion repository on Google
+
1.61 Wed Mar 21 16:09:15 EDT 2007
- Fix 'list/array' context - both keywords are supported
- Upgraded ppport.h to Devel::PPPort 3.11
-threads version 1.61
+threads version 1.62
====================
This module exposes interpreter threads to the Perl level.
ok(! defined($rc), 'Exited: threads->exit()');
-run_perl(prog => 'use threads 1.61;' .
+run_perl(prog => 'use threads 1.62;' .
'threads->exit(86);' .
'exit(99);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
-run_perl(prog => 'use threads 1.61 qw(exit thread_only);' .
+run_perl(prog => 'use threads 1.62 qw(exit thread_only);' .
'threads->create(sub { exit(99); })->join();' .
'exit(86);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
-my $out = run_perl(prog => 'use threads 1.61;' .
+my $out = run_perl(prog => 'use threads 1.62;' .
'threads->create(sub {' .
' exit(99);' .
'});' .
like($out, '1 finished and unjoined', "exit(status) in thread");
-$out = run_perl(prog => 'use threads 1.61 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 1.62 qw(exit thread_only);' .
'threads->create(sub {' .
' threads->set_thread_exit_only(0);' .
' exit(99);' .
like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
-run_perl(prog => 'use threads 1.61;' .
+run_perl(prog => 'use threads 1.62;' .
'threads->create(sub {' .
' $SIG{__WARN__} = sub { exit(99); };' .
' die();' .
exit(0);
}
+ require Thread::Queue;
+
$| = 1;
print("1..29\n"); ### Number of tests that will be run ###
-};
-
-my $TEST;
-BEGIN {
- share($TEST);
- $TEST = 1;
}
-ok(1, 'Loaded');
-sub ok {
- my ($ok, $name) = @_;
+my $q = Thread::Queue->new();
+my $TEST = 1;
- lock($TEST);
- my $id = $TEST++;
-
- # 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]);
+sub ok
+{
+ $q->enqueue(@_);
+
+ while ($q->pending()) {
+ my $ok = $q->dequeue();
+ my $name = $q->dequeue();
+ my $id = $TEST++;
+
+ 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);
}
### Start of Testing ###
+ok(1, 'Loaded');
# Tests freeing the Perl interperter for each thread
# See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details
my ($COUNT, $STARTED) :shared;
sub threading_1 {
+ my $q = shift;
+
my $tid = threads->tid();
- ok($tid, "Thread $tid started");
+ $q->enqueue($tid, "Thread $tid started");
my $id;
{
}
if ($STARTED < 5) {
sleep(1);
- threads->create('threading_1')->detach();
+ threads->create('threading_1', $q)->detach();
}
if ($id == 1) {
lock($COUNT);
$COUNT++;
cond_signal($COUNT);
- ok($tid, "Thread $tid done");
+ $q->enqueue($tid, "Thread $tid done");
}
{
$STARTED = 0;
$COUNT = 0;
- threads->create('threading_1')->detach();
+ threads->create('threading_1', $q)->detach();
{
my $cnt = 0;
while ($cnt < 5) {
sub threading_2 {
+ my $q = shift;
+
my $tid = threads->tid();
- ok($tid, "Thread $tid started");
+ $q->enqueue($tid, "Thread $tid started");
{
lock($STARTED);
$STARTED++;
}
if ($STARTED < 5) {
- threads->create('threading_2')->detach();
+ threads->create('threading_2', $q)->detach();
}
threads->yield();
$COUNT++;
cond_signal($COUNT);
- ok($tid, "Thread $tid done");
+ $q->enqueue($tid, "Thread $tid done");
}
{
$STARTED = 0;
$COUNT = 0;
- threads->create('threading_2')->detach();
+ threads->create('threading_2', $q)->detach();
threads->create(sub {
threads->create(sub { })->join();
})->join();
sub threading_3 {
+ my $q = shift;
+
my $tid = threads->tid();
- ok($tid, "Thread $tid started");
+ $q->enqueue($tid, "Thread $tid started");
{
threads->create(sub {
+ my $q = shift;
+
my $tid = threads->tid();
- ok($tid, "Thread $tid started");
+ $q->enqueue($tid, "Thread $tid started");
sleep(1);
$COUNT++;
cond_signal($COUNT);
- ok($tid, "Thread $tid done");
- })->detach();
+ $q->enqueue($tid, "Thread $tid done");
+ }, $q)->detach();
}
lock($COUNT);
$COUNT++;
cond_signal($COUNT);
- ok($tid, "Thread $tid done");
+ $q->enqueue($tid, "Thread $tid done");
}
{
$COUNT = 0;
threads->create(sub {
- threads->create('threading_3')->detach();
+ threads->create('threading_3', $q)->detach();
{
lock($COUNT);
while ($COUNT < 2) {
exit(0);
}
+ require Thread::Queue;
+
$| = 1;
print("1..78\n"); ### Number of tests that will be run ###
-};
-
-my $TEST;
-BEGIN {
- share($TEST);
- $TEST = 1;
}
-ok(1, 'Loaded');
-sub ok {
- my ($ok, $name) = @_;
+my $q = Thread::Queue->new();
+my $TEST = 1;
- lock($TEST);
- my $id = $TEST++;
+sub ok
+{
+ $q->enqueue(@_) if @_;
- # 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]);
- }
+ while ($q->pending()) {
+ my $ok = $q->dequeue();
+ my $name = $q->dequeue();
+ my $id = $TEST++;
- return ($ok);
+ if ($ok) {
+ print("ok $id - $name\n");
+ } else {
+ print("not ok $id - $name\n");
+ printf("# Failed test at line %d\n", (caller)[2]);
+ }
+ }
}
+
### Start of Testing ###
+ok(1, 'Loaded');
# Tests freeing the Perl interperter for each thread
# See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details
share(%READY);
# Init a thread
-sub th_start {
+sub th_start
+{
+ my $q = shift;
my $tid = threads->tid();
- ok($tid, "Thread $tid started");
+ $q->enqueue($tid, "Thread $tid started");
threads->yield();
# Create next thread
if ($tid < 17) {
my $next = 'th' . ($tid+1);
- my $th = threads->create($next);
+ my $th = threads->create($next, $q);
} else {
# Last thread signals first
- th_signal(1);
+ th_signal($q, 1);
}
# Wait until signalled by another thread
}
$other = delete($READY{$tid});
}
- ok($tid, "Thread $tid received signal from $other");
+ $q->enqueue($tid, "Thread $tid received signal from $other");
threads->yield();
}
# Thread terminating
-sub th_done {
+sub th_done
+{
+ my $q = shift;
my $tid = threads->tid();
lock($COUNT);
$COUNT++;
cond_signal($COUNT);
- ok($tid, "Thread $tid done");
+ $q->enqueue($tid, "Thread $tid done");
}
# Signal another thread to go
sub th_signal
{
+ my $q = shift;
my $other = shift;
my $tid = threads->tid();
- ok($tid, "Thread $tid signalling $other");
+ $q->enqueue($tid, "Thread $tid signalling $other");
lock(%READY);
$READY{$other} = $tid;
#####
-sub th1 {
- th_start();
+sub th1
+{
+ my $q = shift;
+ th_start($q);
threads->detach();
- th_signal(2);
- th_signal(6);
- th_signal(10);
- th_signal(14);
+ th_signal($q, 2);
+ th_signal($q, 6);
+ th_signal($q, 10);
+ th_signal($q, 14);
- th_done();
+ th_done($q);
}
-sub th2 {
- th_start();
+sub th2
+{
+ my $q = shift;
+ th_start($q);
threads->detach();
- th_signal(4);
- th_done();
+ th_signal($q, 4);
+ th_done($q);
}
-sub th6 {
- th_start();
+sub th6
+{
+ my $q = shift;
+ th_start($q);
threads->detach();
- th_signal(8);
- th_done();
+ th_signal($q, 8);
+ th_done($q);
}
-sub th10 {
- th_start();
+sub th10
+{
+ my $q = shift;
+ th_start($q);
threads->detach();
- th_signal(12);
- th_done();
+ th_signal($q, 12);
+ th_done($q);
}
-sub th14 {
- th_start();
+sub th14
+{
+ my $q = shift;
+ th_start($q);
threads->detach();
- th_signal(16);
- th_done();
+ th_signal($q, 16);
+ th_done($q);
}
-sub th4 {
- th_start();
+sub th4
+{
+ my $q = shift;
+ th_start($q);
threads->detach();
- th_signal(3);
- th_done();
+ th_signal($q, 3);
+ th_done($q);
}
-sub th8 {
- th_start();
+sub th8
+{
+ my $q = shift;
+ th_start($q);
threads->detach();
- th_signal(7);
- th_done();
+ th_signal($q, 7);
+ th_done($q);
}
-sub th12 {
- th_start();
+sub th12
+{
+ my $q = shift;
+ th_start($q);
threads->detach();
- th_signal(13);
- th_done();
+ th_signal($q, 13);
+ th_done($q);
}
-sub th16 {
- th_start();
+sub th16
+{
+ my $q = shift;
+ th_start($q);
threads->detach();
- th_signal(17);
- th_done();
+ th_signal($q, 17);
+ th_done($q);
}
-sub th3 {
+sub th3
+{
+ my $q = shift;
my $tid = threads->tid();
my $other = 5;
- th_start();
+ th_start($q);
threads->detach();
- th_signal($other);
+ th_signal($q, $other);
sleep(1);
- ok(1, "Thread $tid getting return from thread $other");
+ $q->enqueue(1, "Thread $tid getting return from thread $other");
my $ret = threads->object($other)->join();
- ok($ret == $other, "Thread $tid saw that thread $other returned $ret");
- th_done();
+ $q->enqueue($ret == $other, "Thread $tid saw that thread $other returned $ret");
+ th_done($q);
}
-sub th5 {
- th_start();
- th_done();
+sub th5
+{
+ my $q = shift;
+ th_start($q);
+ th_done($q);
return (threads->tid());
}
-sub th7 {
+sub th7
+{
+ my $q = shift;
my $tid = threads->tid();
my $other = 9;
- th_start();
+ th_start($q);
threads->detach();
- th_signal($other);
- ok(1, "Thread $tid getting return from thread $other");
+ th_signal($q, $other);
+ $q->enqueue(1, "Thread $tid getting return from thread $other");
my $ret = threads->object($other)->join();
- ok($ret == $other, "Thread $tid saw that thread $other returned $ret");
- th_done();
+ $q->enqueue($ret == $other, "Thread $tid saw that thread $other returned $ret");
+ th_done($q);
}
-sub th9 {
- th_start();
+sub th9
+{
+ my $q = shift;
+ th_start($q);
sleep(1);
- th_done();
+ th_done($q);
return (threads->tid());
}
-sub th13 {
+sub th13
+{
+ my $q = shift;
my $tid = threads->tid();
my $other = 11;
- th_start();
+ th_start($q);
threads->detach();
- th_signal($other);
+ th_signal($q, $other);
sleep(1);
- ok(1, "Thread $tid getting return from thread $other");
+ $q->enqueue(1, "Thread $tid getting return from thread $other");
my $ret = threads->object($other)->join();
- ok($ret == $other, "Thread $tid saw that thread $other returned $ret");
- th_done();
+ $q->enqueue($ret == $other, "Thread $tid saw that thread $other returned $ret");
+ th_done($q);
}
-sub th11 {
- th_start();
- th_done();
+sub th11
+{
+ my $q = shift;
+ th_start($q);
+ th_done($q);
return (threads->tid());
}
-sub th17 {
+sub th17
+{
+ my $q = shift;
my $tid = threads->tid();
my $other = 15;
- th_start();
+ th_start($q);
threads->detach();
- th_signal($other);
- ok(1, "Thread $tid getting return from thread $other");
+ th_signal($q, $other);
+ $q->enqueue(1, "Thread $tid getting return from thread $other");
my $ret = threads->object($other)->join();
- ok($ret == $other, "Thread $tid saw that thread $other returned $ret");
- th_done();
+ $q->enqueue($ret == $other, "Thread $tid saw that thread $other returned $ret");
+ th_done($q);
}
-sub th15 {
- th_start();
+sub th15
+{
+ my $q = shift;
+ th_start($q);
sleep(1);
- th_done();
+ th_done($q);
return (threads->tid());
}
TEST_STARTS_HERE:
{
$COUNT = 0;
- threads->create('th1');
+ threads->create('th1', $q);
{
lock($COUNT);
while ($COUNT < 17) {
cond_wait($COUNT);
+ ok(); # Prints out any intermediate results
}
}
sleep(1);
print("1..0 # Skip: Not using safe signals\n");
exit(0);
}
-}
-
-{
- package Thread::Semaphore;
- use threads::shared;
- sub new {
- my $class = shift;
- my $val : shared = @_ ? shift : 1;
- bless \$val, $class;
- }
+ require Thread::Queue;
+ require Thread::Semaphore;
- sub down {
- my $s = shift;
- lock($$s);
- my $inc = @_ ? shift : 1;
- cond_wait $$s until $$s >= $inc;
- $$s -= $inc;
- }
-
- sub up {
- my $s = shift;
- lock($$s);
- my $inc = @_ ? shift : 1;
- ($$s += $inc) > 0 and cond_broadcast $$s;
- }
-}
-
-BEGIN {
$| = 1;
- print("1..19\n"); ### Number of tests that will be run ###
+ print("1..18\n"); ### Number of tests that will be run ###
};
-my $TEST = 1;
-share($TEST);
-
-ok(1, 'Loaded');
-
-sub ok {
- my ($ok, $name) = @_;
- lock($TEST);
- my $id = $TEST++;
+my $q = Thread::Queue->new();
+my $TEST = 1;
- # 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]);
+sub ok
+{
+ $q->enqueue(@_);
+
+ while ($q->pending()) {
+ my $ok = $q->dequeue();
+ my $name = $q->dequeue();
+ my $id = $TEST++;
+
+ 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);
}
### Start of Testing ###
+ok(1, 'Loaded');
### Thread cancel ###
my @errs :shared;
$SIG{__WARN__} = sub { push(@errs, @_); };
-
sub thr_func {
+ my $q = shift;
+
# Thread 'cancellation' signal handler
$SIG{'KILL'} = sub {
- ok(1, 'Thread received signal');
+ $q->enqueue(1, 'Thread received signal');
die("Thread killed\n");
};
# Thread sleeps until signalled
- ok(1, 'Thread sleeping');
- {
- local $SIG{'INT'} = sub {};
- sleep(5);
- }
+ $q->enqueue(1, 'Thread sleeping');
+ sleep(1) for (1..10);
# Should not go past here
- ok(0, 'Thread terminated normally');
+ $q->enqueue(0, 'Thread terminated normally');
return ('ERROR');
}
-
# Create thread
-my $thr = threads->create('thr_func');
+my $thr = threads->create('thr_func', $q);
ok($thr && $thr->tid() == 2, 'Created thread');
threads->yield();
sleep(1);
# Signal thread
-ok($thr->kill('KILL'), 'Signalled thread');
+ok($thr->kill('KILL') == $thr, 'Signalled thread');
threads->yield();
-# Interrupt thread's sleep call
-{
- # We can't be sure whether the signal itself will get delivered to this
- # thread or the sleeping thread
- local $SIG{'INT'} = sub {};
- ok(kill('INT', $$) || $^O eq 'MSWin32', q/Interrupt thread's sleep call/);
-}
-
# Cleanup
my $rc = $thr->join();
ok(! $rc, 'No thread return value');
sub thr_func2
{
+ my $q = shift;
+
my $sema = shift;
- ok($sema, 'Thread received semaphore');
+ $q->enqueue($sema, 'Thread received semaphore');
# Set up the signal handler for suspension/resumption
$SIG{'STOP'} = sub {
- ok(1, 'Thread suspending');
+ $q->enqueue(1, 'Thread suspending');
$sema->down();
- ok(1, 'Thread resuming');
+ $q->enqueue(1, 'Thread resuming');
$sema->up();
};
# Set up the signal handler for graceful termination
my $term = 0;
$SIG{'TERM'} = sub {
- ok(1, 'Thread caught termination signal');
+ $q->enqueue(1, 'Thread caught termination signal');
$term = 1;
};
sleep(1);
}
- ok(1, 'Thread done');
+ $q->enqueue(1, 'Thread done');
return ('OKAY');
}
ok($sema, 'Semaphore created');
# Create a thread and send it the semaphore
-$thr = threads->create('thr_func2', $sema);
+$thr = threads->create('thr_func2', $q, $sema);
ok($thr && $thr->tid() == 3, 'Created thread');
threads->yield();
sleep(1);
# Suspend the thread
$sema->down();
-ok($thr->kill('STOP'), 'Suspended thread');
+ok($thr->kill('STOP') == $thr, 'Suspended thread');
threads->yield();
sleep(1);
$rc = $thr->join();
ok($rc eq 'OKAY', 'Thread return value');
-ok($thr->kill('TERM'), 'Ignore signal to terminated thread');
+ok($thr->kill('TERM') == $thr, 'Ignore signal to terminated thread');
# EOF
# bugid #24165
-run_perl(prog => 'use threads 1.61;' .
+run_perl(prog => 'use threads 1.62;' .
'sub a{threads->create(shift)} $t = a sub{};' .
'$t->tid; $t->join; $t->tid',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
use strict;
use warnings;
-our $VERSION = '1.61';
+our $VERSION = '1.62';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
} elsif ($sym =~ /^str/i) {
import overload ('""' => \&tid);
- } elsif ($sym =~ /^(?:all|yield)$/) {
+ } elsif ($sym =~ /^(?::all|yield)$/) {
push(@EXPORT, qw(yield));
} else {
=head1 VERSION
-This document describes threads version 1.61
+This document describes threads version 1.62
=head1 SYNOPSIS
L<http://www.cpanforum.com/dist/threads>
Annotated POD for L<threads>:
-L<http://annocpan.org/~JDHEDDEN/threads-1.61/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.62/threads.pm>
+
+Source repository:
+L<http://code.google.com/p/threads-shared/>
L<threads::shared>, L<perlthrtut>
CODE:
if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
if (--items < 2) {
- Perl_croak(aTHX_ "Usage: threads->create(\\%specs, function, ...)");
+ Perl_croak(aTHX_ "Usage: threads->create(\\%%specs, function, ...)");
}
specs = (HV*)SvRV(ST(1));
idx = 1;
projects / p5sagit/p5-mst-13.2.git / commitdiff