[perl #107366] Don’t clone GVs during thread join

unless they are orphaned.

This commit stops globs that still reside in their stashes from being
cloned during a join.

That way, a sub like sub{$::x++}, when cloned into a subthread and
returned from it, will still point to the same $::x.

This commit takes the conservative approach of copying on those globs
that can be found under their names in the original thread.

While this doesn’t work for all cases, it’s probably not possible to
make it work all the time.

diff --git a/sv.c b/sv.c
index 8b266c3..471caba 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -11813,6 +11813,27 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                return dstr;
            }
         }
+       else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
+           HV *stash = GvSTASH(sstr);
+           const HEK * hvname;
+           if (stash && (hvname = HvNAME_HEK(stash))) {
+               /** don't clone GVs if they already exist **/
+               SV **svp;
+               stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
+                                   HEK_UTF8(hvname) ? SVf_UTF8 : 0);
+               svp = hv_fetch(
+                       stash, GvNAME(sstr),
+                       GvNAMEUTF8(sstr)
+                           ? -GvNAMELEN(sstr)
+                           :  GvNAMELEN(sstr),
+                       0
+                     );
+               if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
+                   ptr_table_store(PL_ptr_table, sstr, *svp);
+                   return *svp;
+               }
+           }
+        }
     }
 
     /* create anew and remember what it is */

diff --git a/t/op/threads.t b/t/op/threads.t
index a07fc4a..1181a00 100644 (file)
--- a/t/op/threads.t
+++ b/t/op/threads.t
@@ -9,7 +9,7 @@ BEGIN {
      skip_all_without_config('useithreads');
      skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
 
-     plan(25);
+     plan(26);
 }
 
 use strict;
@@ -385,4 +385,10 @@ EOF
   ok(1, "Pipes shared between threads do not block when closed");
 }
 
+# [perl #105208] Typeglob clones should not be cloned again during a join
+{
+  threads->create(sub { sub { $::hypogamma = 3 } })->join->();
+  is $::hypogamma, 3, 'globs cloned and joined are not recloned';
+}
+
 # EOF