Modified perl-23179 patch for 5.38.4

Author: shawnlaffan

share/64bit-5.38.4.1.pp

@@ -76,8 +76,8 @@
             '<dist_sharedir>/perl-5.36/perlexe.rc.tt'           => 'win32/perlexe.rc',
             '<dist_sharedir>/perl-5.40/posix_bessel.patch'      => '*',
             '<dist_sharedir>/perl-5.38/vmem.patch'              => '*',
-            #'<dist_sharedir>/perl-5.40/gh23179_no_delta.patch'  => '*',  #  perl build fails if this is applied
-            #'<dist_sharedir>/perl-5.38/scope_types.h'           => 'scope_types.h',
+            '<dist_sharedir>/perl-5.38/gh23179_no_delta_or_PERL_RE_BUILD_AUX.patch'  => '*',
+            '<dist_sharedir>/perl-5.38/scope_types.h'           => 'scope_types.h',
             'config_H.gc'                                 => {
                 I_DBM  => 'define',
                 I_GDBM => 'define',

share/perl-5.38/gh23179_no_delta_or_PERL_RE_BUILD_AUX.patch

@@ -0,0 +1,259 @@
+From f1b6fa6bb53480921fb0083d9c8b583b8df2e904 Mon Sep 17 00:00:00 2001
+From: Tony Cook <[email protected]>
+Date: Mon, 24 Feb 2025 15:56:09 +1100
+Subject: [PATCH 1/3] regcomp: handle cloning the rexc cleanup in the scope
+ stack
+
+Previous on Win32 this could cause a double-free of the RExC state if
+an emulated fork was done with the free of the state on the scope
+stack.
+
+Use a custom save type and prevent freeing in the cloned process to
+prevent the double-free.
+
+Fixes #23022
+
+XXX scope_types.h is elided from original patch and applied separately 
+after regen as it did not patch cleanly.
+
+XXX2: Removed ifdef for PERL_RE_BUILD_AUX
+
+---
+ embed.fnc            |  4 ++-
+ embed.h              |  1 +
+ proto.h              |  6 ++++
+ regcomp.c            | 16 +++++++----
+ regen/scope_types.pl |  1 +
+ scope.c              |  6 ++++
+ scope.h              |  5 ++++
+ scope_types.h        | 68 +++++++++++++++++++++++---------------------
+ sv.c                 |  5 ++++
+ 9 files changed, 73 insertions(+), 39 deletions(-)
+
+diff --git a/embed.fnc b/embed.fnc
+index 0332f63875ec..90b518a03f0a 100644
+--- a/embed.fnc
++++ b/embed.fnc
+@@ -2791,6 +2791,9 @@ Cp	|char * |re_intuit_start|NN REGEXP * const rx			\
+ 				|NULLOK re_scream_pos_data *data
+ Cp	|SV *	|re_intuit_string					\
+ 				|NN REGEXP  * const r
++
++p	|void	|release_RExC_state					\
++				|NN void *vstate
+ Xp	|REGEXP *|re_op_compile |NULLOK SV ** const patternp		\
+ 				|int pat_count				\
+ 				|NULLOK OP *expr			\
+@@ -2799,7 +2802,6 @@ Xp	|REGEXP *|re_op_compile |NULLOK SV ** const patternp		\
+ 				|NULLOK bool *is_bare_re		\
+ 				|const U32 rx_flags			\
+ 				|const U32 pm_flags
+-
+ ATdp	|void	|repeatcpy	|NN char *to				\
+ 				|NN const char *from			\
+ 				|SSize_t len				\
+diff --git a/embed.h b/embed.h
+index e1e2bf4d02f1..d6926854177b 100644
+--- a/embed.h
++++ b/embed.h
+@@ -1200,6 +1200,7 @@
+ #   define refcounted_he_new_pv(a,b,c,d,e)      Perl_refcounted_he_new_pv(aTHX_ a,b,c,d,e)
+ #   define refcounted_he_new_pvn(a,b,c,d,e,f)   Perl_refcounted_he_new_pvn(aTHX_ a,b,c,d,e,f)
+ #   define refcounted_he_new_sv(a,b,c,d,e)      Perl_refcounted_he_new_sv(aTHX_ a,b,c,d,e)
++#   define release_RExC_state(a)                Perl_release_RExC_state(aTHX_ a)
+ #   define report_evil_fh(a)                    Perl_report_evil_fh(aTHX_ a)
+ #   define report_wrongway_fh(a,b)              Perl_report_wrongway_fh(aTHX_ a,b)
+ #   define rpeep(a)                             Perl_rpeep(aTHX_ a)
+diff --git a/proto.h b/proto.h
+index e132956f8ac8..6ded4aeb247f 100644
+--- a/proto.h
++++ b/proto.h
+@@ -3893,6 +3893,12 @@ PERL_CALLCONV void
+ Perl_reginitcolors(pTHX);
+ #define PERL_ARGS_ASSERT_REGINITCOLORS
+ 
++PERL_CALLCONV void
++Perl_release_RExC_state(pTHX_ void *vstate)
++        __attribute__visibility__("hidden");
++#define PERL_ARGS_ASSERT_RELEASE_REXC_STATE     \
++        assert(vstate)
++
+ PERL_CALLCONV void
+ Perl_repeatcpy(char *to, const char *from, SSize_t len, IV count);
+ #define PERL_ARGS_ASSERT_REPEATCPY              \
+diff --git a/regcomp.c b/regcomp.c
+index a79221079269..14e1390062e5 100644
+--- a/regcomp.c
++++ b/regcomp.c
+@@ -1356,15 +1356,19 @@ S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
+     return true;
+ }
+ 
+-static void
+-release_RExC_state(pTHX_ void *vstate) {
+-    RExC_state_t *pRExC_state = (RExC_state_t *)vstate;
++
++
++void
++Perl_release_RExC_state(pTHX_ void *vstate) {
++    PERL_ARGS_ASSERT_RELEASE_REXC_STATE;
+ 
++    RExC_state_t *pRExC_state = (RExC_state_t *)vstate;
++    
+     /* Any or all of these might be NULL.
+ 
+        There's no point in setting them to NULL after the free, since
+        pRExC_state is about to be released.
+-     */
++    */
+     SvREFCNT_dec(RExC_rx_sv);
+     Safefree(RExC_open_parens);
+     Safefree(RExC_close_parens);
+@@ -1374,6 +1378,8 @@ release_RExC_state(pTHX_ void *vstate) {
+     Safefree(pRExC_state);
+ }
+ 
++
++
+ /*
+  * Perl_re_op_compile - the perl internal RE engine's function to compile a
+  * regular expression into internal code.
+@@ -1475,7 +1481,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
+      * or error. */
+     Newxz(pRExC_state, 1, RExC_state_t);
+ 
+-    SAVEDESTRUCTOR_X(release_RExC_state, pRExC_state);
++    SAVE_FREE_REXC_STATE(pRExC_state);
+ 
+     DEBUG_r({
+         /* and then initialize RExC_mysv1 and RExC_mysv2 early so if
+diff --git a/regen/scope_types.pl b/regen/scope_types.pl
+index 3a7522d734b9..a3f406951793 100644
+--- a/regen/scope_types.pl
++++ b/regen/scope_types.pl
+@@ -137,6 +137,7 @@ BEGIN
+ SAVEt_FREEPADNAME
+ SAVEt_STRLEN_SMALL
+ SAVEt_FREERCPV
++SAVEt_FREE_REXC_STATE
+ 
+ /* two args */
+ 
+diff --git a/scope.c b/scope.c
+index 210ea36da3e8..b8063c27760b 100644
+--- a/scope.c
++++ b/scope.c
+@@ -1391,6 +1391,12 @@ Perl_leave_scope(pTHX_ I32 base)
+             Safefree(a0.any_ptr);
+             break;
+ 
++        case SAVEt_FREE_REXC_STATE:
++            a0 = ap[0];
++            if (a0.any_ptr)
++                release_RExC_state(a0.any_ptr);
++            break;
++
+         case SAVEt_CLEARPADRANGE:
+         {
+             I32 i;
+diff --git a/scope.h b/scope.h
+index 311c4a32ec1b..eccd3aaba2dc 100644
+--- a/scope.h
++++ b/scope.h
+@@ -183,6 +183,11 @@ scope has the given name. C<name> must be a literal string.
+ #define SAVESETSVFLAGS(sv,mask,val) save_set_svflags(sv,mask,val)
+ #define SAVEFREECOPHH(h)            save_pushptr((void *)(h), SAVEt_FREECOPHH)
+ 
++#if defined(PERL_CORE) || defined(PERL_EXT)
++#  define SAVE_FREE_REXC_STATE(p) \
++        save_pushptr((void *)(p), SAVEt_FREE_REXC_STATE)
++#endif
++
+ #define SAVEDELETE(h,k,l) \
+           save_delete(MUTABLE_HV(h), (char*)(k), (I32)(l))
+ #define SAVEHDELETE(h,s) \
+diff --git a/sv.c b/sv.c
+index e8c6e65a2717..ae6d09dea28a 100644
+--- a/sv.c
++++ b/sv.c
+@@ -15515,6 +15515,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
+             c = (char*)POPPTR(ss,ix);
+             TOPPTR(nss,ix) = pv_dup_inc(c);
+             break;
++        case SAVEt_FREE_REXC_STATE:
++            (void)POPPTR(ss, ix);
++            /* free only once */
++            TOPPTR(nss, ix) = NULL;
++            break;
+         case SAVEt_FREERCPV:
+             c = (char *)POPPTR(ss,ix);
+             TOPPTR(nss,ix) = rcpv_copy(c);
+
+From c54f9ca07b8390e9b917ea3b66fa605c8cf24b09 Mon Sep 17 00:00:00 2001
+From: Tony Cook <[email protected]>
+Date: Mon, 14 Apr 2025 10:46:13 +1000
+Subject: [PATCH 3/3] regcomp: ensure the RExC_state freed earlier rather than
+ later
+
+388bf71 (ignoring #23022 for now) ensured that the RExC_state
+and its controlled pointers were freed once and only once,
+regardless of whether re_op_compile() returned normally or threw
+an exception.
+
+Unfortunately that free could happen very later, surviving well beyond
+when the regexp was compiled.
+
+Add an ENTER/LEAVE pair to ensure the cleanup is done immediately
+on a normal return.
+---
+ regcomp.c | 9 ++++++++-
+ 1 file changed, 8 insertions(+), 1 deletion(-)
+
+diff --git a/regcomp.c b/regcomp.c
+index 14e1390062e5..0a84ad07606f 100644
+--- a/regcomp.c
++++ b/regcomp.c
+@@ -1481,6 +1481,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
+      * or error. */
+     Newxz(pRExC_state, 1, RExC_state_t);
+ 
++    ENTER_with_name("re_op_compile");
+     SAVE_FREE_REXC_STATE(pRExC_state);
+ 
+     DEBUG_r({
+@@ -1578,6 +1579,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
+                 "Precompiled pattern%s\n",
+                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
+ 
++            LEAVE_with_name("re_op_compile");
++
+             return (REGEXP*)re;
+         }
+     }
+@@ -1593,7 +1596,9 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
+             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
+                                         (IN_BYTES ? 0 : SvUTF8(pat)));
+         }
+-        return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
++        REGEXP *re = CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
++        LEAVE_with_name("re_op_compile");
++        return re;
+     }
+ 
+     /* ignore the utf8ness if the pattern is 0 length */
+@@ -1643,6 +1648,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
+             Perl_re_printf( aTHX_  "%sSkipping recompilation of unchanged REx%s %s\n",
+                           PL_colors[4], PL_colors[5], s);
+         });
++        LEAVE_with_name("re_op_compile");
+         return old_re;
+     }
+ 
+@@ -2477,6 +2483,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
+     if (old_re && SvREADONLY(old_re))
+         SvREADONLY_on(Rx);
+ #endif
++    LEAVE_with_name("re_op_compile");
+     return Rx;
+ }
+