threads 1.34 - state methods
authorJerry D. Hedden <jdhedden@cpan.org>
Thu, 6 Jul 2006 07:33:13 +0000 (00:33 -0700)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Fri, 7 Jul 2006 14:12:59 +0000 (14:12 +0000)
From: "Jerry D. Hedden" <jerry@hedden.us>
Message-ID: <20060706073313.fb30e530d17747c2b054d625b8945d88.baa39d91bc.wbe@email.secureserver.net>

p4raw-id: //depot/perl@28501

MANIFEST
ext/threads/Changes
ext/threads/README
ext/threads/t/context.t
ext/threads/t/state.t [new file with mode: 0644]
ext/threads/t/thread.t
ext/threads/threads.pm
ext/threads/threads.xs

index 473888b..5c8b6dc 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1178,6 +1178,7 @@ ext/threads/t/list.t              Test threads->list()
 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.
index c86f243..5581b8f 100755 (executable)
@@ -1,5 +1,9 @@
 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))
index d8706ac..a753098 100755 (executable)
@@ -1,4 +1,4 @@
-threads version 1.33
+threads version 1.34
 ====================
 
 This module needs perl 5.8.0 or later compiled with 'useithreads'.
index fda0233..d23bbd0 100644 (file)
@@ -28,7 +28,7 @@ BEGIN {
     }
 
     $| = 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;
@@ -101,4 +101,59 @@ $thr = threads->create({'void' => 1}, 'foo', 'void');
 $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
diff --git a/ext/threads/t/state.t b/ext/threads/t/state.t
new file mode 100644 (file)
index 0000000..331cd8c
--- /dev/null
@@ -0,0 +1,190 @@
+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
index 73b7e3a..bd44660 100644 (file)
@@ -171,7 +171,7 @@ package main;
 
 # 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,
index 7e5cffb..43a3be9 100755 (executable)
@@ -5,7 +5,7 @@ use 5.008;
 use strict;
 use warnings;
 
-our $VERSION = '1.33';
+our $VERSION = '1.34';
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -80,6 +80,11 @@ sub exit
     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;
 
@@ -108,7 +113,7 @@ threads - Perl interpreter-based threads
 
 =head1 VERSION
 
-This document describes threads version 1.33
+This document describes threads version 1.34
 
 =head1 SYNOPSIS
 
@@ -148,6 +153,9 @@ This document describes threads version 1.33
     my @threads = threads->list();
     my $thread_count = threads->list();
 
+    my @running = threads->list(threads::running);
+    my @joinable = threads->list(threads::joinable);
+
     if ($thr1 == $thr2) {
         ...
     }
@@ -159,7 +167,17 @@ This document describes threads version 1.33
     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');
 
@@ -319,8 +337,22 @@ code.
 
 =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)
 
@@ -363,6 +395,34 @@ Class method that allows a thread to obtain its own I<handle>.
 
 =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
@@ -415,6 +475,16 @@ of the C<-E<gt>create()> call:
     # 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
@@ -737,7 +807,7 @@ 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.33/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.34/threads.pm>
 
 L<threads::shared>, L<perlthrtut>
 
index 5e6d16c..40bd2d1 100755 (executable)
@@ -122,8 +122,8 @@ S_ithread_clear(pTHX_ ithread *thread)
 {
     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) {
@@ -827,15 +827,21 @@ ithread_list(...)
         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;
@@ -846,6 +852,20 @@ ithread_list(...)
             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)));
@@ -1185,6 +1205,66 @@ ithread_set_stack_size(...)
         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 */