ext/threads/t/problems.t Test various memory problems
ext/threads/t/stack_env.t Tests for stack limits
ext/threads/t/stack.t Tests for stack limits
+ext/threads/t/state.t Tests state methods
ext/threads/t/stress_cv.t Test with multiple threads, coderef cv argument.
ext/threads/t/stress_re.t Test with multiple threads, string cv argument and regexes.
ext/threads/t/stress_string.t Test with multiple threads, string cv argument.
Revision history for Perl extension threads.
+1.34 Thu Jul 6 10:29:37 EDT 2006
+ - Added ->is_running, ->is_detached, ->is_joinable, ->wantarray
+ - Enhanced ->list to return running or joinable threads
+
1.33 Mon Jul 3 10:11:20 EDT 2006
- 'exit' inside a thread silently terminates thread only
- Added 'threads->exit()' (just calls CORE::exit(0))
-threads version 1.33
+threads version 1.34
====================
This module needs perl 5.8.0 or later compiled with 'useithreads'.
}
$| = 1;
- print("1..13\n"); ### Number of tests that will be run ###
+ print("1..31\n"); ### Number of tests that will be run ###
};
my $TEST;
$res = $thr->join();
ok(! defined($res), 'Explicit void context');
+
+sub bar
+{
+ my $context = shift;
+ my $wantarray = threads->wantarray();
+
+ if ($wantarray) {
+ ok($context eq 'array', 'Array context');
+ return ('array');
+ } elsif (defined($wantarray)) {
+ ok($context eq 'scalar', 'Scalar context');
+ return 'scalar';
+ } else {
+ ok($context eq 'void', 'Void context');
+ return;
+ }
+}
+
+($thr) = threads->create('bar', 'array');
+my $ctx = $thr->wantarray();
+ok($ctx, 'Implicit array context');
+($res) = $thr->join();
+ok($res eq 'array', 'Implicit array context');
+
+$thr = threads->create('bar', 'scalar');
+$ctx = $thr->wantarray();
+ok(defined($ctx) && !$ctx, 'Implicit scalar context');
+$res = $thr->join();
+ok($res eq 'scalar', 'Implicit scalar context');
+
+threads->create('bar', 'void');
+($thr) = threads->list();
+$ctx = $thr->wantarray();
+ok(! defined($ctx), 'Implicit void context');
+$res = $thr->join();
+ok(! defined($res), 'Implicit void context');
+
+$thr = threads->create({'context' => 'array'}, 'bar', 'array');
+$ctx = $thr->wantarray();
+ok($ctx, 'Explicit array context');
+($res) = $thr->join();
+ok($res eq 'array', 'Explicit array context');
+
+($thr) = threads->create({'scalar' => 'scalar'}, 'bar', 'scalar');
+$ctx = $thr->wantarray();
+ok(defined($ctx) && !$ctx, 'Explicit scalar context');
+$res = $thr->join();
+ok($res eq 'scalar', 'Explicit scalar context');
+
+$thr = threads->create({'void' => 1}, 'bar', 'void');
+$ctx = $thr->wantarray();
+ok(! defined($ctx), 'Explicit void context');
+$res = $thr->join();
+ok(! defined($res), 'Explicit void context');
+
# EOF
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ 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 threads;
+
+BEGIN {
+ eval {
+ require threads::shared;
+ import threads::shared;
+ };
+ if ($@ || ! $threads::shared::threads_shared) {
+ print("1..0 # Skip: threads::shared not available\n");
+ exit(0);
+ }
+
+ $| = 1;
+ print("1..53\n"); ### Number of tests that will be run ###
+};
+
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
+
+ok(1, 'Loaded');
+
+sub ok {
+ my ($ok, $name) = @_;
+
+ 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]);
+ }
+
+ return ($ok);
+}
+
+
+### Start of Testing ###
+
+my ($READY, $GO, $DONE) :shared = (0, 0, 0);
+
+sub do_thread
+{
+ {
+ lock($DONE);
+ $DONE = 0;
+ lock($READY);
+ $READY = 1;
+ cond_signal($READY);
+ }
+
+ lock($GO);
+ while (! $GO) {
+ cond_wait($GO);
+ }
+ $GO = 0;
+
+ lock($READY);
+ $READY = 0;
+ lock($DONE);
+ $DONE = 1;
+ cond_signal($DONE);
+}
+
+sub wait_until_ready
+{
+ lock($READY);
+ while (! $READY) {
+ cond_wait($READY);
+ }
+}
+
+sub thread_go
+{
+ {
+ lock($GO);
+ $GO = 1;
+ cond_signal($GO);
+ }
+
+ {
+ lock($DONE);
+ while (! $DONE) {
+ cond_wait($DONE);
+ }
+ }
+ threads->yield();
+ sleep(1);
+}
+
+
+my $thr = threads->create('do_thread');
+wait_until_ready();
+ok($thr->is_running(), 'thread running');
+ok(threads->list(threads::running) == 1, 'thread running list');
+ok(! $thr->is_detached(), 'thread not detached');
+ok(! $thr->is_joinable(), 'thread not joinable');
+ok(threads->list(threads::joinable) == 0, 'thread joinable list');
+ok(threads->list(threads::all) == 1, 'thread list');
+
+thread_go();
+ok(! $thr->is_running(), 'thread not running');
+ok(threads->list(threads::running) == 0, 'thread running list');
+ok(! $thr->is_detached(), 'thread not detached');
+ok($thr->is_joinable(), 'thread joinable');
+ok(threads->list(threads::joinable) == 1, 'thread joinable list');
+ok(threads->list(threads::all) == 1, 'thread list');
+
+$thr->join();
+ok(! $thr->is_running(), 'thread not running');
+ok(threads->list(threads::running) == 0, 'thread running list');
+ok(! $thr->is_detached(), 'thread not detached');
+ok(! $thr->is_joinable(), 'thread not joinable');
+ok(threads->list(threads::joinable) == 0, 'thread joinable list');
+ok(threads->list(threads::all) == 0, 'thread list');
+
+$thr = threads->create('do_thread');
+$thr->detach();
+ok($thr->is_running(), 'thread running');
+ok(threads->list(threads::running) == 0, 'thread running list');
+ok($thr->is_detached(), 'thread detached');
+ok(! $thr->is_joinable(), 'thread not joinable');
+ok(threads->list(threads::joinable) == 0, 'thread joinable list');
+ok(threads->list(threads::all) == 0, 'thread list');
+
+thread_go();
+ok(! $thr->is_running(), 'thread not running');
+ok(threads->list(threads::running) == 0, 'thread running list');
+ok($thr->is_detached(), 'thread detached');
+ok(! $thr->is_joinable(), 'thread not joinable');
+ok(threads->list(threads::joinable) == 0, 'thread joinable list');
+
+$thr = threads->create(sub {
+ ok(! threads->is_detached(), 'thread not detached');
+ ok(threads->list(threads::running) == 1, 'thread running list');
+ ok(threads->list(threads::joinable) == 0, 'thread joinable list');
+ ok(threads->list(threads::all) == 1, 'thread list');
+ threads->detach();
+ do_thread();
+ ok(threads->is_detached(), 'thread detached');
+ ok(threads->list(threads::running) == 0, 'thread running list');
+ ok(threads->list(threads::joinable) == 0, 'thread joinable list');
+ ok(threads->list(threads::all) == 0, 'thread list');
+});
+
+wait_until_ready();
+ok($thr->is_running(), 'thread running');
+ok(threads->list(threads::running) == 0, 'thread running list');
+ok($thr->is_detached(), 'thread detached');
+ok(! $thr->is_joinable(), 'thread not joinable');
+ok(threads->list(threads::joinable) == 0, 'thread joinable list');
+ok(threads->list(threads::all) == 0, 'thread list');
+
+thread_go();
+ok(! $thr->is_running(), 'thread not running');
+ok(threads->list(threads::running) == 0, 'thread running list');
+ok($thr->is_detached(), 'thread detached');
+ok(! $thr->is_joinable(), 'thread not joinable');
+ok(threads->list(threads::joinable) == 0, 'thread joinable list');
+
+$thr = threads->create(sub {
+ ok(! threads->is_detached(), 'thread not detached');
+ ok(threads->list(threads::running) == 1, 'thread running list');
+ ok(threads->list(threads::joinable) == 0, 'thread joinable list');
+ ok(threads->list(threads::all) == 1, 'thread list');
+})->join();
+
+# EOF
# bugid #24165
-run_perl(prog => 'use threads 1.33;
+run_perl(prog => 'use threads 1.34;
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.33';
+our $VERSION = '1.34';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
CORE::exit(0);
}
+# 'Constant' args for threads->list()
+sub threads::all { }
+sub threads::running { 1 }
+sub threads::joinable { 0 }
+
# 'new' is an alias for 'create'
*new = \&create;
=head1 VERSION
-This document describes threads version 1.33
+This document describes threads version 1.34
=head1 SYNOPSIS
my @threads = threads->list();
my $thread_count = threads->list();
+ my @running = threads->list(threads::running);
+ my @joinable = threads->list(threads::joinable);
+
if ($thr1 == $thr2) {
...
}
my $thr = threads->create({ 'context' => 'list',
'stack_size' => 32*4096 },
\&foo);
- my @results = $thr->join();
+
+ # Get thread's context
+ my $wantarray = $thr->wantarray();
+
+ # Check thread's state
+ if ($thr->is_running()) {
+ sleep(1);
+ }
+ if ($thr->is_joinable()) {
+ $thr->join();
+ }
$thr->kill('SIGUSR1');
=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 threads->list(threads::all)
+
+=item threads->list(threads::running)
+
+=item threads->list(threads::joinable)
+
+With no arguments (or using C<threads::all>) and 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.
+
+With a I<true> argument (using C<threads::running>), returns a list of all
+non-detached I<threads> objects that are still running.
+
+With a I<false> argument (using C<threads::joinable>), returns a list of all
+non-joined, non-detached I<threads> objects that have finished running (i.e.,
+for which C<-E<gt>join()> will not I<block>).
=item $thr1->equal($thr2)
=back
+=head1 THREAD STATE
+
+The following boolean methods are useful in determining the I<state> of a
+thread.
+
+=over
+
+=item $thr->is_running()
+
+Returns true if a thread is still running (i.e., if its entry point function
+has not yet finished/exited).
+
+=item $thr->is_joinable()
+
+Returns true if the thread has finished running, is not detached and has not
+yet been joined. In other works, the thread is ready to be joined and will
+not I<block>.
+
+=item $thr->is_detached()
+
+Returns true if the thread has been detached.
+
+=item threads->is_detached()
+
+Class method that allows a thread to determine whether or not it is detached.
+
+=back
+
=head1 THREAD CONTEXT
As with subroutines, the type of value returned from a thread's entry point
# Create thread in void context
threads->create(...);
+=head2 $thr->wantarray()
+
+This returns the thread's context in the same manner as
+L<wantarray()|perlfunc/"wantarray">.
+
+=head2 threads->wantarray()
+
+Class method to return the current thread's context. This is the same as
+running L<wantarray()|perlfunc/"wantarray"> in the current thread.
+
=head1 THREAD STACK SIZE
The default per-thread stack size for different platforms varies
L<http://www.cpanforum.com/dist/threads>
Annotated POD for L<threads>:
-L<http://annocpan.org/~JDHEDDEN/threads-1.33/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.34/threads.pm>
L<threads::shared>, L<perlthrtut>
{
PerlInterpreter *interp;
- assert(thread->state & PERL_ITHR_FINISHED &&
- thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
+ assert((thread->state & PERL_ITHR_FINISHED) &&
+ (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)));
interp = thread->interp;
if (interp) {
ithread *thread;
int list_context;
IV count = 0;
+ int want_running;
PPCODE:
/* Class method only */
if (SvROK(ST(0)))
- Perl_croak(aTHX_ "Usage: threads->list()");
+ Perl_croak(aTHX_ "Usage: threads->list(...)");
classname = (char *)SvPV_nolen(ST(0));
/* Calling context */
list_context = (GIMME_V == G_ARRAY);
+ /* Running or joinable parameter */
+ if (items > 1) {
+ want_running = SvTRUE(ST(1));
+ }
+
/* Walk through threads list */
MUTEX_LOCK(&create_destruct_mutex);
for (thread = threads->next;
if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
continue;
}
+
+ /* Filter per parameter */
+ if (items > 1) {
+ if (want_running) {
+ if (thread->state & PERL_ITHR_FINISHED) {
+ continue; /* Not running */
+ }
+ } else {
+ if (! (thread->state & PERL_ITHR_FINISHED)) {
+ continue; /* Still running - not joinable yet */
+ }
+ }
+ }
+
/* Push object on stack if list context */
if (list_context) {
XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
XST_mIV(0, old_size);
/* XSRETURN(1); - implied */
+
+void
+ithread_is_running(...)
+ PREINIT:
+ ithread *thread;
+ CODE:
+ /* Object method only */
+ if (! sv_isobject(ST(0)))
+ Perl_croak(aTHX_ "Usage: $thr->is_running()");
+
+ thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
+ MUTEX_LOCK(&thread->mutex);
+ ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes;
+ MUTEX_UNLOCK(&thread->mutex);
+ /* XSRETURN(1); - implied */
+
+
+void
+ithread_is_detached(...)
+ PREINIT:
+ ithread *thread;
+ CODE:
+ thread = SV_to_ithread(aTHX_ ST(0));
+ MUTEX_LOCK(&thread->mutex);
+ ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no;
+ MUTEX_UNLOCK(&thread->mutex);
+ /* XSRETURN(1); - implied */
+
+
+void
+ithread_is_joinable(...)
+ PREINIT:
+ ithread *thread;
+ CODE:
+ /* Object method only */
+ if (! sv_isobject(ST(0)))
+ Perl_croak(aTHX_ "Usage: $thr->is_joinable()");
+
+ thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
+ MUTEX_LOCK(&thread->mutex);
+ ST(0) = ((thread->state & PERL_ITHR_FINISHED) &&
+ ! (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
+ ? &PL_sv_yes : &PL_sv_no;
+ MUTEX_UNLOCK(&thread->mutex);
+ /* XSRETURN(1); - implied */
+
+
+void
+ithread_wantarray(...)
+ PREINIT:
+ ithread *thread;
+ CODE:
+ thread = SV_to_ithread(aTHX_ ST(0));
+ MUTEX_LOCK(&thread->mutex);
+ ST(0) = (thread->gimme & G_ARRAY) ? &PL_sv_yes :
+ (thread->gimme & G_VOID) ? &PL_sv_undef
+ /* G_SCALAR */ : &PL_sv_no;
+ MUTEX_UNLOCK(&thread->mutex);
+ /* XSRETURN(1); - implied */
+
#endif /* USE_ITHREADS */
projects / p5sagit/p5-mst-13.2.git / commitdiff