[perl #78088] [PATCH] Upgrade to threads 1.81

  [DELTA]

  The attached patch makes the CPAN distribution of 'threads'
  compatible with with v5.13.2 and later.

4 files changed, 93 insertions, 12 deletions

diff --git a/dist/threads/lib/threads.pm b/dist/threads/lib/threads.pm
index 175b8df26c..e98fb50d13 100644
--- a/dist/threads/lib/threads.pm
+++ b/dist/threads/lib/threads.pm
@@ -5,7 +5,7 @@ use 5.008;
 use strict;
 use warnings;
 
-our $VERSION = '1.79_01';
+our $VERSION = '1.81';
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -134,7 +134,7 @@ threads - Perl interpreter-based threads
 
 =head1 VERSION
 
-This document describes threads version 1.79
+This document describes threads version 1.81
 
 =head1 SYNOPSIS
 
@@ -1040,7 +1040,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.79/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.81/threads.pm>
 
 Source repository:
 L<http://code.google.com/p/threads-shared/>
diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t
index 208f7b3b62..a3f2106240 100644
--- 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.79;' .
+run_perl(prog => 'use threads 1.81;' .
                  '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.79 qw(exit thread_only);' .
+run_perl(prog => 'use threads 1.81 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.79 qw(exit thread_only);' .
     is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
 }
 
-my $out = run_perl(prog => 'use threads 1.79;' .
+my $out = run_perl(prog => 'use threads 1.81;' .
                            'threads->create(sub {' .
                            '    exit(99);' .
                            '});' .
@@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 1.79;' .
 like($out, '1 finished and unjoined', "exit(status) in thread");
 
 
-$out = run_perl(prog => 'use threads 1.79 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 1.81 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.79 qw(exit thread_only);' .
 like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
 
 
-run_perl(prog => 'use threads 1.79;' .
+run_perl(prog => 'use threads 1.81;' .
                  'threads->create(sub {' .
                  '   $SIG{__WARN__} = sub { exit(99); };' .
                  '   die();' .
diff --git a/dist/threads/t/thread.t b/dist/threads/t/thread.t
index 32c50b8d4d..b63c0a3212 100644
--- a/dist/threads/t/thread.t
+++ b/dist/threads/t/thread.t
@@ -161,7 +161,7 @@ package main;
 
 # bugid #24165
 
-run_perl(prog => 'use threads 1.79;' .
+run_perl(prog => 'use threads 1.81;' .
                  'sub a{threads->create(shift)} $t = a sub{};' .
                  '$t->tid; $t->join; $t->tid',
          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index 6c38bdc3fb..71fc7a7881 100644
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -774,6 +774,36 @@ S_ithread_create(
      * context for the duration of our work for new interpreter.
      */
     {
+#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1)
+        CLONE_PARAMS clone_param;
+
+        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 = NULL;
+
+        clone_param.flags = 0;
+        if (SvPOK(init_function)) {
+            thread->init_function = newSV(0);
+            sv_copypv(thread->init_function, init_function);
+        } else {
+            thread->init_function =
+                SvREFCNT_inc(sv_dup(init_function, &clone_param));
+        }
+
+        thread->params = params = newAV();
+        av_extend(params, params_end - params_start - 1);
+        AvFILLp(params) = params_end - params_start - 1;
+        array = AvARRAY(params);
+        while (params_start < params_end) {
+            *array++ = SvREFCNT_inc(sv_dup(*params_start++, &clone_param));
+        }
+#else
         CLONE_PARAMS *clone_param = Perl_clone_params_new(aTHX, thread->interp);
 
         dTHXa(thread->interp);
@@ -800,7 +830,8 @@ S_ithread_create(
         while (params_start < params_end) {
             *array++ = SvREFCNT_inc(sv_dup(*params_start++, clone_param));
         }
-	Perl_clone_params_del(clone_param);	
+        Perl_clone_params_del(clone_param);
+#endif
 
 #if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7
         /* The code below checks that anything living on the tmps stack and
@@ -1239,6 +1270,28 @@ ithread_join(...)
         /* Get the return value from the call_sv */
         /* Objects do not survive this process - FIXME */
         if ((thread->gimme & G_WANT) != G_VOID) {
+#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1)
+            AV *params_copy;
+            PerlInterpreter *other_perl;
+            CLONE_PARAMS clone_params;
+
+            params_copy = thread->params;
+            other_perl = thread->interp;
+            clone_params.stashes = newAV();
+            clone_params.flags = CLONEf_JOIN_IN;
+            PL_ptr_table = ptr_table_new();
+            S_ithread_set(aTHX_ thread);
+            /* Ensure 'meaningful' addresses retain their meaning */
+            ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
+            ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
+            ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
+            params = (AV *)sv_dup((SV*)params_copy, &clone_params);
+            S_ithread_set(aTHX_ current_thread);
+            SvREFCNT_dec(clone_params.stashes);
+            SvREFCNT_inc_void(params);
+            ptr_table_free(PL_ptr_table);
+            PL_ptr_table = NULL;
+#else
             AV *params_copy;
             PerlInterpreter *other_perl = thread->interp;
             CLONE_PARAMS *clone_params = Perl_clone_params_new(other_perl, aTHX);
@@ -1253,10 +1306,11 @@ ithread_join(...)
             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
             params = (AV *)sv_dup((SV*)params_copy, clone_params);
             S_ithread_set(aTHX_ current_thread);
-	    Perl_clone_params_del(clone_params);	
+            Perl_clone_params_del(clone_params);
             SvREFCNT_inc_void(params);
             ptr_table_free(PL_ptr_table);
             PL_ptr_table = NULL;
+#endif
         }
 
         /* If thread didn't die, then we can free its interpreter */
@@ -1638,6 +1692,32 @@ ithread_error(...)
 
         /* If thread died, then clone the error into the calling thread */
         if (thread->state & PERL_ITHR_DIED) {
+#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1)
+            PerlInterpreter *other_perl;
+            CLONE_PARAMS clone_params;
+            ithread *current_thread;
+
+            other_perl = thread->interp;
+            clone_params.stashes = newAV();
+            clone_params.flags = CLONEf_JOIN_IN;
+            PL_ptr_table = ptr_table_new();
+            current_thread = S_ithread_get(aTHX);
+            S_ithread_set(aTHX_ thread);
+            /* Ensure 'meaningful' addresses retain their meaning */
+            ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
+            ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
+            ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
+            err = sv_dup(thread->err, &clone_params);
+            S_ithread_set(aTHX_ current_thread);
+            SvREFCNT_dec(clone_params.stashes);
+            SvREFCNT_inc_void(err);
+            /* If error was an object, bless it into the correct class */
+            if (thread->err_class) {
+                sv_bless(err, gv_stashpv(thread->err_class, 1));
+            }
+            ptr_table_free(PL_ptr_table);
+            PL_ptr_table = NULL;
+#else
             PerlInterpreter *other_perl = thread->interp;
             CLONE_PARAMS *clone_params = Perl_clone_params_new(other_perl, aTHX);
             ithread *current_thread;
@@ -1652,7 +1732,7 @@ ithread_error(...)
             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
             err = sv_dup(thread->err, clone_params);
             S_ithread_set(aTHX_ current_thread);
-	    Perl_clone_params_del(clone_params);
+            Perl_clone_params_del(clone_params);
             SvREFCNT_inc_void(err);
             /* If error was an object, bless it into the correct class */
             if (thread->err_class) {
@@ -1660,6 +1740,7 @@ ithread_error(...)
             }
             ptr_table_free(PL_ptr_table);
             PL_ptr_table = NULL;
+#endif
         }
 
         MUTEX_UNLOCK(&thread->mutex);