Upgrade dist/threads to 1.77 from CPAN

While doing so fix a tiny, little POD error to prevent breakage of core
tests. (blead is upstream for threads.pm)

diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 1608efa..5134cee 100755 (executable)
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -1559,7 +1559,7 @@ use File::Glob qw(:case);
     'threads' =>
        {
        'MAINTAINER'    => 'jdhedden',
-       'DISTRIBUTION'  => 'JDHEDDEN/threads-1.75.tar.gz',
+       'DISTRIBUTION'  => 'JDHEDDEN/threads-1.77.tar.gz',
        'FILES'         => q[dist/threads],
        'EXCLUDED'      => [ qw(examples/pool.pl
                                t/pod.t

diff --git a/dist/threads/t/basic.t b/dist/threads/t/basic.t
index 19ce793..f4d030b 100644 (file)
--- a/dist/threads/t/basic.t
+++ b/dist/threads/t/basic.t
@@ -27,7 +27,7 @@ sub ok {
 
 BEGIN {
     $| = 1;
-    print("1..33\n");   ### Number of tests that will be run ###
+    print("1..34\n");   ### Number of tests that will be run ###
 };
 
 use threads;
@@ -153,14 +153,17 @@ $thrx = threads->object();
 ok(30, ! defined($thrx), 'No object');
 $thrx = threads->object(undef);
 ok(31, ! defined($thrx), 'No object');
-$thrx = threads->object(0);
-ok(32, ! defined($thrx), 'No object');
 
 threads->import('stringify');
 $thr1 = threads->create(sub {});
-ok(33, "$thr1" eq $thr1->tid(), 'Stringify');
+ok(32, "$thr1" eq $thr1->tid(), 'Stringify');
 $thr1->join();
 
+# ->object($tid) works like ->self() when $tid is thread's TID
+$thrx = threads->object(threads->tid());
+ok(33, defined($thrx), 'Main thread object');
+ok(34, 0 == $thrx->tid(), "Check so that tid for threads work for main thread");
+
 exit(0);
 
 # EOF

diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t
index bb1cec0..29c3dca 100644 (file)
--- a/dist/threads/t/exit.t
+++ b/dist/threads/t/exit.t
@@ -48,7 +48,7 @@ my $rc = $thr->join();
 ok(! defined($rc), 'Exited: threads->exit()');
 
 
-run_perl(prog => 'use threads 1.75;' .
+run_perl(prog => 'use threads 1.77;' .
                  'threads->exit(86);' .
                  'exit(99);',
          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -98,7 +98,7 @@ $rc = $thr->join();
 ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
 
 
-run_perl(prog => 'use threads 1.75 qw(exit thread_only);' .
+run_perl(prog => 'use threads 1.77 qw(exit thread_only);' .
                  'threads->create(sub { exit(99); })->join();' .
                  'exit(86);',
          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -108,7 +108,7 @@ run_perl(prog => 'use threads 1.75 qw(exit thread_only);' .
     is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
 }
 
-my $out = run_perl(prog => 'use threads 1.75;' .
+my $out = run_perl(prog => 'use threads 1.77;' .
                            'threads->create(sub {' .
                            '    exit(99);' .
                            '});' .
@@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 1.75;' .
 like($out, '1 finished and unjoined', "exit(status) in thread");
 
 
-$out = run_perl(prog => 'use threads 1.75 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 1.77 qw(exit thread_only);' .
                         'threads->create(sub {' .
                         '   threads->set_thread_exit_only(0);' .
                         '   exit(99);' .
@@ -141,7 +141,7 @@ $out = run_perl(prog => 'use threads 1.75 qw(exit thread_only);' .
 like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
 
 
-run_perl(prog => 'use threads 1.75;' .
+run_perl(prog => 'use threads 1.77;' .
                  'threads->create(sub {' .
                  '   $SIG{__WARN__} = sub { exit(99); };' .
                  '   die();' .

diff --git a/dist/threads/t/thread.t b/dist/threads/t/thread.t
index 6f33cd4..b390215 100644 (file)
--- a/dist/threads/t/thread.t
+++ b/dist/threads/t/thread.t
@@ -20,7 +20,7 @@ BEGIN {
     }
 
     $| = 1;
-    print("1..34\n");   ### Number of tests that will be run ###
+    print("1..35\n");   ### Number of tests that will be run ###
 };
 
 print("ok 1 - Loaded\n");
@@ -161,7 +161,7 @@ package main;
 
 # bugid #24165
 
-run_perl(prog => 'use threads 1.75;' .
+run_perl(prog => 'use threads 1.77;' .
                  'sub a{threads->create(shift)} $t = a sub{};' .
                  '$t->tid; $t->join; $t->tid',
          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -304,6 +304,26 @@ SKIP: {
         "counts of calls to DESTROY");
 }
 
+# Bug 73330 - Apply magic to arg to ->object()
+{
+    my @tids :shared;
+
+    my $thr = threads->create(sub {
+                        lock(@tids);
+                        push(@tids, threads->tid());
+                        cond_signal(@tids);
+                    });
+
+    {
+        lock(@tids);
+        cond_wait(@tids) while (! @tids);
+    }
+
+    ok(threads->object($_), 'Got threads object') foreach (@tids);
+
+    $thr->join();
+}
+
 exit(0);
 
 # EOF

diff --git a/dist/threads/threads.pm b/dist/threads/threads.pm
index 4552e50..b0c8fe3 100644 (file)
--- a/dist/threads/threads.pm
+++ b/dist/threads/threads.pm
@@ -5,7 +5,7 @@ use 5.008;
 use strict;
 use warnings;
 
-our $VERSION = '1.75';
+our $VERSION = '1.77';
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -134,7 +134,7 @@ threads - Perl interpreter-based threads
 
 =head1 VERSION
 
-This document describes threads version 1.75
+This document describes threads version 1.77
 
 =head1 SYNOPSIS
 
@@ -361,9 +361,10 @@ key) will cause its ID to be used as the value:
 =item threads->object($tid)
 
 This will return the I<threads> object for the I<active> thread associated
-with the specified thread ID.  Returns C<undef> if there is no thread
-associated with the TID, if the thread is joined or detached, if no TID is
-specified or if the specified TID is undef.
+with the specified thread ID.  If C<$tid> is the value for the current thread,
+then this call works the same as C<-E<gt>self()>.  Otherwise, returns C<undef>
+if there is no thread associated with the TID, if the thread is joined or
+detached, if no TID is specified or if the specified TID is undef.
 
 =item threads->yield()
 
@@ -902,6 +903,18 @@ other threads are started afterwards.
 If the above does not work, or is not adequate for your application, then file
 a bug report on L<http://rt.cpan.org/Public/> against the problematic module.
 
+=item Memory consumption
+
+On most systems, frequent and continual creation and destruction of threads
+can lead to ever-increasing growth in the memory footprint of the Perl
+interpreter.  While it is simple to just launch threads and then
+C<-E<gt>join()> or C<-E<gt>detach()> them, for long-lived applications, it is
+better to maintain a pool of threads, and to reuse them for the work needed,
+using L<queues|Thread::Queue> to notify threads of pending work.  The CPAN
+distribution of this module contains a simple example
+(F<examples/pool_reuse.pl>) illustrating the creation, use and monitoring of a
+pool of I<reusable> threads.
+
 =item Current working directory
 
 On all platforms except MSWin32, the setting for the current working directory
@@ -975,7 +988,7 @@ involved, you may be able to work around this by returning a serialized
 version of the object (e.g., using L<Data::Dumper> or L<Storable>), and then
 reconstituting it in the joining thread.  If you're using Perl 5.10.0 or
 later, and if the class supports L<shared objects|threads::shared/"OBJECTS">,
-you can pass them via L<shared queues| Thread::Queue>.
+you can pass them via L<shared queues|Thread::Queue>.
 
 =item END blocks in threads
 
@@ -1021,7 +1034,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.75/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.77/threads.pm>
 
 Source repository:
 L<http://code.google.com/p/threads-shared/>

diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index 9e602a1..b0f7dc8 100755 (executable)
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -52,7 +52,7 @@ typedef perl_os_thread pthread_t;
 
 /* Values for 'state' member */
 #define PERL_ITHR_DETACHED           1 /* Thread has been detached */
-#define PERL_ITHR_JOINED             2 /* Thread has been joined */
+#define PERL_ITHR_JOINED             2 /* Thread is being / has been joined */
 #define PERL_ITHR_FINISHED           4 /* Thread has finished execution */
 #define PERL_ITHR_THREAD_EXIT_ONLY   8 /* exit() only exits current thread */
 #define PERL_ITHR_NONVIABLE         16 /* Thread creation failed */
@@ -1409,6 +1409,7 @@ void
 ithread_object(...)
     PREINIT:
         char *classname;
+        SV *arg;
         UV tid;
         ithread *thread;
         int state;
@@ -1421,34 +1422,47 @@ ithread_object(...)
         }
         classname = (char *)SvPV_nolen(ST(0));
 
-        if ((items < 2) || ! SvOK(ST(1))) {
+        /* Turn $tid from PVLV to SV if needed (bug #73330) */
+        arg = ST(1);
+        SvGETMAGIC(arg);
+
+        if ((items < 2) || ! SvOK(arg)) {
             XSRETURN_UNDEF;
         }
 
         /* threads->object($tid) */
-        tid = SvUV(ST(1));
+        tid = SvUV(arg);
 
-        /* Walk through threads list */
-        MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
-        for (thread = MY_POOL.main_thread.next;
-             thread != &MY_POOL.main_thread;
-             thread = thread->next)
-        {
-            /* Look for TID */
-            if (thread->tid == tid) {
-                /* Ignore if detached or joined */
-                MUTEX_LOCK(&thread->mutex);
-                state = thread->state;
-                MUTEX_UNLOCK(&thread->mutex);
-                if (! (state & PERL_ITHR_UNCALLABLE)) {
-                    /* Put object on stack */
-                    ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
-                    have_obj = 1;
+        /* If current thread wants its own object, then behave the same as
+           ->self() */
+        thread = S_ithread_get(aTHX);
+        if (thread->tid == tid) {
+            ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
+            have_obj = 1;
+
+        } else {
+            /* Walk through threads list */
+            MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
+            for (thread = MY_POOL.main_thread.next;
+                 thread != &MY_POOL.main_thread;
+                 thread = thread->next)
+            {
+                /* Look for TID */
+                if (thread->tid == tid) {
+                    /* Ignore if detached or joined */
+                    MUTEX_LOCK(&thread->mutex);
+                    state = thread->state;
+                    MUTEX_UNLOCK(&thread->mutex);
+                    if (! (state & PERL_ITHR_UNCALLABLE)) {
+                        /* Put object on stack */
+                        ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
+                        have_obj = 1;
+                    }
+                    break;
                 }
-                break;
             }
+            MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
         }
-        MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
 
         if (! have_obj) {
             XSRETURN_UNDEF;