[perl #96126] Allocate CvFILE more simply

See the thread starting at:
http://www.nntp.perl.org/group/perl.perl5.porters/2011/07/msg175161.html

Instead of assuming that only Perl subs have mallocked CvFILEs and
only under threads, resulting in various hackery to borrow parts of
the SvPVX buffer where that assumption proves wrong, we can simply
add another flag (DYNFILE) to indicate whether CvFILE is mallocked,
instead of trying to use the ISXSUB flag for two purposes.

This simplifies the code greatly, eliminating bug #96126 in the pro-
cess (which had to do with sv_dup not knowing about the hackery that
this commit removes).

I removed that comment from cv_ckproto_len about CONSTSUBs doubling up
the buffer field, as it is no longer relevant.  But I still left the
code as it is, since it’s better to do an explicit length check.

8 files changed, 59 insertions, 72 deletions

diff --git a/cv.h b/cv.h
index b2fe16d888..f47d171908 100644
--- a/cv.h
+++ b/cv.h
@@ -51,9 +51,11 @@ For more information, see L<perlguts>.
 #define CvGV_set(cv,gv)	Perl_cvgv_set(aTHX_ cv, gv)
 #define CvFILE(sv)	((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file
 #ifdef USE_ITHREADS
-#  define CvFILE_set_from_cop(sv, cop)	(CvFILE(sv) = savepv(CopFILE(cop)))
+#  define CvFILE_set_from_cop(sv, cop)	\
+    (CvFILE(sv) = savepv(CopFILE(cop)), CvDYNFILE_on(sv))
 #else
-#  define CvFILE_set_from_cop(sv, cop)	(CvFILE(sv) = CopFILE(cop))
+#  define CvFILE_set_from_cop(sv, cop)	\
+    (CvFILE(sv) = CopFILE(cop), CvDYNFILE_off(sv))
 #endif
 #define CvFILEGV(sv)	(gv_fetchfile(CvFILE(sv)))
 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
@@ -83,6 +85,7 @@ For more information, see L<perlguts>.
 #define CVf_NODEBUG	0x0200	/* no DB::sub indirection for this CV
 				   (esp. useful for special XSUBs) */
 #define CVf_CVGV_RC	0x0400	/* CvGV is reference counted */
+#define CVf_DYNFILE	0x1000	/* The filename isn't static  */
 
 /* This symbol for optimised communication between toke.c and op.c: */
 #define CVf_BUILTIN_ATTRS	(CVf_METHOD|CVf_LVALUE)
@@ -140,6 +143,10 @@ For more information, see L<perlguts>.
 #define CvCVGV_RC_on(cv)	(CvFLAGS(cv) |= CVf_CVGV_RC)
 #define CvCVGV_RC_off(cv)	(CvFLAGS(cv) &= ~CVf_CVGV_RC)
 
+#define CvDYNFILE(cv)		(CvFLAGS(cv) & CVf_DYNFILE)
+#define CvDYNFILE_on(cv)	(CvFLAGS(cv) |= CVf_DYNFILE)
+#define CvDYNFILE_off(cv)	(CvFLAGS(cv) &= ~CVf_DYNFILE)
+
 /* Flags for newXS_flags  */
 #define XS_DYNAMIC_FILENAME	0x01	/* The filename isn't static  */
 
diff --git a/dump.c b/dump.c
index c19cb8e16b..232ab0167d 100644
--- a/dump.c
+++ b/dump.c
@@ -1446,6 +1446,7 @@ const struct flag_to_name cv_flags_names[] = {
     {CVf_METHOD, "METHOD,"},
     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
     {CVf_CVGV_RC, "CVGV_RC,"},
+    {CVf_DYNFILE, "DYNFILE,"},
     {CVf_ISXSUB, "ISXSUB,"}
 };
 
diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index d582a8f03c..f9074f0e96 100644
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -25,6 +25,8 @@ Good    @>>>>>
 $::mmmm
 .
 
+use constant thr => $Config{useithreads};
+
 sub do_test {
     my $todo = $_[3];
     my $repeat_todo = $_[4];
@@ -54,11 +56,10 @@ sub do_test {
 	    # legitimate regexp, it still isn't true. Seems easier and clearer
 	    # things that look like comments.
 
-	    my $version_condition = qr/\$] [<>]=? 5\.\d\d\d/;
 	    # Could do this is in a s///mge but seems clearer like this:
 	    $pattern = join '', map {
 		# If we identify the version condition, take *it* out whatever
-		s/\s*# ($version_condition(?: && $version_condition)?)$//
+		s/\s*# (\$].*)$//
 		    ? (eval $1 ? $_ : '')
 		    : $_ # Didn't match, so this line is in
 	    } split /^/, $pattern;
@@ -264,7 +265,8 @@ do_test('reference to anon sub with empty prototype',
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = 2
-    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\)
+    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
+    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
     IV = 0					# $] < 5.009
     NV = 0					# $] < 5.009
     PROTOTYPE = ""
@@ -279,7 +281,8 @@ do_test('reference to anon sub with empty prototype',
     MUTEXP = $ADDR
     OWNER = $ADDR)?
     FLAGS = 0x404				# $] < 5.009
-    FLAGS = 0x490				# $] >= 5.009
+    FLAGS = 0x490		# $] >= 5.009 && ($] < 5.015 || !thr)
+    FLAGS = 0x1490				# $] >= 5.015 && thr
     OUTSIDE_SEQ = \\d+
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
@@ -293,7 +296,8 @@ do_test('reference to named subroutine without prototype',
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = (3|4)
-    FLAGS = \\(\\)
+    FLAGS = \\(\\)				# $] < 5.015 || !thr
+    FLAGS = \\(DYNFILE\\)			# $] >= 5.015 && thr
     IV = 0					# $] < 5.009
     NV = 0					# $] < 5.009
     COMP_STASH = $ADDR\\t"main"
@@ -303,17 +307,17 @@ do_test('reference to named subroutine without prototype',
     XSUBANY = 0					# $] < 5.009
     GVGV::GV = $ADDR\\t"main" :: "do_test"
     FILE = ".*\\b(?i:peek\\.t)"
-    DEPTH = 1
-(?:    MUTEXP = $ADDR
-    OWNER = $ADDR
-)?    FLAGS = 0x0
+    DEPTH = 1(?:
+    MUTEXP = $ADDR
+    OWNER = $ADDR)?
+    FLAGS = 0x0					# $] < 5.015 || !thr
+    FLAGS = 0x1000				# $] >= 5.015 && thr
     OUTSIDE_SEQ = \\d+
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
-      \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$version_condition"
       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"			# $] < 5.009
       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0	# $] >= 5.009
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
@@ -601,7 +605,8 @@ do_test('constant subroutine',
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = (2)
-    FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)
+    FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)		# $] < 5.015
+    FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\)	# $] >= 5.015
     IV = 0					# $] < 5.009
     NV = 0					# $] < 5.009
     PROTOTYPE = ""
@@ -622,7 +627,8 @@ do_test('constant subroutine',
     OWNER = $ADDR)?
     FLAGS = 0x200				# $] < 5.009
     FLAGS = 0xc00				# $] >= 5.009 && $] < 5.013
-    FLAGS = 0xc					# $] >= 5.013
+    FLAGS = 0xc					# $] >= 5.013 && $] < 5.015
+    FLAGS = 0x100c				# $] >= 5.015
     OUTSIDE_SEQ = 0
     PADLIST = 0x0
     OUTSIDE = 0x0 \\(null\\)');	
@@ -670,7 +676,8 @@ do_test('FORMAT',
   RV = $ADDR
   SV = PVFM\\($ADDR\\) at $ADDR
     REFCNT = 2
-    FLAGS = \\(\\)
+    FLAGS = \\(\\)				# $] < 5.015 || !thr
+    FLAGS = \\(DYNFILE\\)			# $] >= 5.015 && thr
     IV = 0					# $] < 5.009
     NV = 0					# $] < 5.009
 (?:    PV = 0
@@ -680,11 +687,12 @@ do_test('FORMAT',
     XSUB = 0x0					# $] < 5.009
     XSUBANY = 0					# $] < 5.009
     GVGV::GV = $ADDR\\t"main" :: "PIE"
-    FILE = ".*\\b(?i:peek\\.t)"
-(?:    DEPTH = 0
+    FILE = ".*\\b(?i:peek\\.t)"(?:
+    DEPTH = 0
     MUTEXP = $ADDR
-    OWNER = $ADDR
-)?    FLAGS = 0x0
+    OWNER = $ADDR)?
+    FLAGS = 0x0					# $] < 5.015 || !thr
+    FLAGS = 0x1000				# $] >= 5.015 && thr
     OUTSIDE_SEQ = \\d+
     LINES = 0
     PADLIST = $ADDR
diff --git a/op.c b/op.c
index ae599ad55f..40f327bf51 100644
--- a/op.c
+++ b/op.c
@@ -6258,8 +6258,6 @@ Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
 {
     PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
 
-    /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
-       relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
 	 || (p && (len != SvCUR(cv) /* Not the same length.  */
 		   || memNE(p, SvPVX_const(cv), len))))
@@ -6619,12 +6617,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    CvOUTSIDE(PL_compcv) = temp_cv;
 	    CvPADLIST(PL_compcv) = temp_av;
 
-#ifdef USE_ITHREADS
-	    if (CvFILE(cv) && !CvISXSUB(cv)) {
-		/* for XSUBs CvFILE point directly to static memory; __FILE__ */
+	    if (CvFILE(cv) && CvDYNFILE(cv)) {
 		Safefree(CvFILE(cv));
     }
-#endif
 	    CvFILE_set_from_cop(cv, PL_curcop);
 	    CvSTASH_set(cv, PL_curstash);
 
@@ -6883,7 +6878,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
 	CopSTASH_set(PL_curcop,stash);
     }
 
-    /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
+    /* file becomes the CvFILE. For an XS, it's usually static storage,
        and so doesn't get free()d.  (It's expected to be from the C pre-
        processor __FILE__ directive). But we need a dynamically allocated one,
        and we need it to get freed.  */
@@ -6911,40 +6906,10 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
     PERL_ARGS_ASSERT_NEWXS_FLAGS;
 
     if (flags & XS_DYNAMIC_FILENAME) {
-	/* We need to "make arrangements" (ie cheat) to ensure that the
-	   filename lasts as long as the PVCV we just created, but also doesn't
-	   leak  */
-	STRLEN filename_len = strlen(filename);
-	STRLEN proto_and_file_len = filename_len;
-	char *proto_and_file;
-	STRLEN proto_len;
-
-	if (proto) {
-	    proto_len = strlen(proto);
-	    proto_and_file_len += proto_len;
-
-	    Newx(proto_and_file, proto_and_file_len + 1, char);
-	    Copy(proto, proto_and_file, proto_len, char);
-	    Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
-	} else {
-	    proto_len = 0;
-	    proto_and_file = savepvn(filename, filename_len);
-	}
-
-	/* This gets free()d.  :-)  */
-	sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
-			SV_HAS_TRAILING_NUL);
-	if (proto) {
-	    /* This gives us the correct prototype, rather than one with the
-	       file name appended.  */
-	    SvCUR_set(cv, proto_len);
-	} else {
-	    SvPOK_off(cv);
-	}
-	CvFILE(cv) = proto_and_file + proto_len;
-    } else {
-	sv_setpv(MUTABLE_SV(cv), proto);
+	CvFILE(cv) = savepv(filename);
+	CvDYNFILE_on(cv);
     }
+    sv_setpv(MUTABLE_SV(cv), proto);
     return cv;
 }
 
@@ -7020,6 +6985,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
     (void)gv_fetchfile(filename);
     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
 				   an external constant string */
+    assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
     CvISXSUB_on(cv);
     CvXSUB(cv) = subaddr;
 
diff --git a/pad.c b/pad.c
index da35a09cad..eb88afc32c 100644
--- a/pad.c
+++ b/pad.c
@@ -341,13 +341,10 @@ Perl_cv_undef(pTHX_ CV *cv)
 	    PTR2UV(cv), PTR2UV(PL_comppad))
     );
 
-#ifdef USE_ITHREADS
-    if (CvFILE(cv) && !CvISXSUB(cv)) {
-	/* for XSUBs CvFILE point directly to static memory; __FILE__ */
+    if (CvFILE(cv) && CvDYNFILE(cv)) {
 	Safefree(CvFILE(cv));
     }
     CvFILE(cv) = NULL;
-#endif
 
     if (!CvISXSUB(cv) && CvROOT(cv)) {
 	if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
@@ -1875,12 +1872,8 @@ Perl_cv_clone(pTHX_ CV *proto)
     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
     CvCLONED_on(cv);
 
-#ifdef USE_ITHREADS
-    CvFILE(cv)		= CvISXSUB(proto) ? CvFILE(proto)
-					  : savepv(CvFILE(proto));
-#else
-    CvFILE(cv)		= CvFILE(proto);
-#endif
+    CvFILE(cv)		= CvDYNFILE(proto) ? savepv(CvFILE(proto))
+					   : CvFILE(proto);
     CvGV_set(cv,CvGV(proto));
     CvSTASH_set(cv, CvSTASH(proto));
     OP_REFCNT_LOCK;
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index e4e45dc346..0c9488a9aa 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -585,6 +585,13 @@ comma operator, which gives all but the last item void context.  There is
 no such thing as void lvalue context, so it was a mistake for Perl to try
 to force it [perl #96942].
 
+=item *
+
+Every subroutine has a filename associated with it, that the debugger uses.
+The one associated with constant subroutines used to be misallocated when
+cloned under threads.  Consequently, debugging threaded applications could
+result in memory corruption [perl #96126].
+
 =back
 
 =head1 Known Problems
diff --git a/sv.c b/sv.c
index e3426ad5c2..63b73f721a 100644
--- a/sv.c
+++ b/sv.c
@@ -12016,11 +12016,11 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
 		    OP_REFCNT_LOCK;
 		    CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
 		    OP_REFCNT_UNLOCK;
-		    CvFILE(dstr) = SAVEPV(CvFILE(dstr));
 		} else if (CvCONST(dstr)) {
 		    CvXSUBANY(dstr).any_ptr =
 			sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
 		}
+		if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
 		/* don't dup if copying back - CvGV isn't refcounted, so the
 		 * duped GV may never be freed. A bit of a hack! DAPM */
 		SvANY(MUTABLE_CV(dstr))->xcv_gv =
diff --git a/universal.c b/universal.c
index c891b54bcf..76702ffb39 100644
--- a/universal.c
+++ b/universal.c
@@ -1293,8 +1293,13 @@ Perl_boot_core_UNIVERSAL(pTHX)
     PL_amagic_generation++;
 
     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
-    CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
-	= (char *)file;
+    {
+	CV * const cv =
+	    newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
+	Safefree(CvFILE(cv));
+	CvFILE(cv) = (char *)file;
+	CvDYNFILE_off(cv);
+    }
 }
 
 /*