Calling cv_undef() on the CV created by newCONSTSUB() would leak like

a Jumblie's preferred maritime craft. To free CvFILE for this case,
take advantage of the 0 length prototype that will also be there,
and hang it from the prototype. To do this properly means changing
code to actually pay attention to SvCUR() on prototypes. It turns out
that we always know the length of the prototype string, so this may
be faster. Certainly, it's a memory saving (even ignoring the leak).

p4raw-id: //depot/perl@27896

10 files changed, 75 insertions, 28 deletions

diff --git a/dump.c b/dump.c
index 5fa6700587..a973a41c19 100644
--- a/dump.c
+++ b/dump.c
@@ -1552,8 +1552,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	}
 	break;
     case SVt_PVCV:
-	if (SvPOK(sv))
-	    Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n", SvPV_nolen_const(sv));
+	if (SvPOK(sv)) {
+	    STRLEN len;
+	    const char *const proto =  SvPV_const(sv, len);
+	    Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
+			     (int) len, proto);
+	}
 	/* FALL THROUGH */
     case SVt_PVFM:
 	do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
diff --git a/embed.fnc b/embed.fnc
index b9db13e7ae..82736d7258 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -150,7 +150,10 @@ Afnp	|void	|sv_setpvf_mg_nocontext|NN SV* sv|NN const char* pat|...
 Afnp	|int	|fprintf_nocontext|NN PerlIO* stream|NN const char* fmt|...
 Afnp	|int	|printf_nocontext|NN const char* fmt|...
 #endif
-p	|void	|cv_ckproto	|NN const CV* cv|NULLOK const GV* gv|NULLOK const char* p
+bp	|void	|cv_ckproto	|NN const CV* cv|NULLOK const GV* gv\
+				|NULLOK const char* p
+p	|void	|cv_ckproto_len	|NN const CV* cv|NULLOK const GV* gv\
+				|NULLOK const char* p|const STRLEN len
 pd	|CV*	|cv_clone	|NN CV* proto
 ApdR	|SV*	|gv_const_sv	|NN GV* gv
 ApdR	|SV*	|cv_const_sv	|NULLOK CV* cv
diff --git a/embed.h b/embed.h
index 68d3b2e586..430b4973de 100644
--- a/embed.h
+++ b/embed.h
@@ -117,6 +117,7 @@
 #endif
 #ifdef PERL_CORE
 #define cv_ckproto		Perl_cv_ckproto
+#define cv_ckproto_len		Perl_cv_ckproto_len
 #define cv_clone		Perl_cv_clone
 #endif
 #define gv_const_sv		Perl_gv_const_sv
@@ -2281,6 +2282,7 @@
 #endif
 #ifdef PERL_CORE
 #define cv_ckproto(a,b,c)	Perl_cv_ckproto(aTHX_ a,b,c)
+#define cv_ckproto_len(a,b,c,d)	Perl_cv_ckproto_len(aTHX_ a,b,c,d)
 #define cv_clone(a)		Perl_cv_clone(aTHX_ a)
 #endif
 #define gv_const_sv(a)		Perl_gv_const_sv(aTHX_ a)
diff --git a/global.sym b/global.sym
index ef432ddea0..257a2fcaf0 100644
--- a/global.sym
+++ b/global.sym
@@ -74,6 +74,7 @@ Perl_sv_catpvf_mg_nocontext
 Perl_sv_setpvf_mg_nocontext
 Perl_fprintf_nocontext
 Perl_printf_nocontext
+Perl_cv_ckproto
 Perl_gv_const_sv
 Perl_cv_const_sv
 Perl_cv_undef
diff --git a/mathoms.c b/mathoms.c
index 967e0353ec..a2511b9f91 100644
--- a/mathoms.c
+++ b/mathoms.c
@@ -1236,6 +1236,11 @@ Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
     sv_usepvn_flags(sv,ptr,len, 0);
 }
 
+void
+Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
+{
+    cv_ckproto_len(cv, gv, p, p ? strlen(p) : 0);
+}
 #endif /* NO_MATHOMS */
 
 /*
diff --git a/op.c b/op.c
index 57e4a1b872..86d01d4b85 100644
--- a/op.c
+++ b/op.c
@@ -4814,9 +4814,15 @@ Perl_cv_undef(pTHX_ CV *cv)
 }
 
 void
-Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
-{
-    if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
+Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
+		    const STRLEN 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))))
+	 && ckWARN_d(WARN_PROTOTYPE)) {
 	SV* const msg = sv_newmortal();
 	SV* name = NULL;
 
@@ -4831,7 +4837,7 @@ Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
 	    sv_catpvs(msg, ": none");
 	sv_catpvs(msg, " vs ");
 	if (p)
-	    Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
+	    Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
 	else
 	    sv_catpvs(msg, "none");
 	Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
@@ -5036,7 +5042,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    {
 		Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
 	    }
-	    cv_ckproto((CV*)gv, NULL, ps);
+	    cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
 	}
 	if (ps)
 	    sv_setpvn((SV*)gv, ps, ps_len);
@@ -5080,7 +5086,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
          * skipping the prototype check
          */
         if (exists || SvPOK(cv))
-	    cv_ckproto(cv, gv, ps);
+	    cv_ckproto_len(cv, gv, ps, ps_len);
 	/* already defined (or promised)? */
 	if (exists || GvASSUMECV(gv)) {
 	    if ((!block
@@ -5391,6 +5397,15 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
 {
     dVAR;
     CV* cv;
+#ifdef USE_ITHREADS
+    const char *const temp_p = CopFILE(PL_curcop);
+    const STRLEN len = strlen(temp_p);
+#else
+    SV *const temp_sv = CopFILESV(PL_curcop);
+    STRLEN len;
+    const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+#endif
+    char *const file = temp_p ? savepvn(temp_p, len) : NULL;
 
     ENTER;
 
@@ -5407,10 +5422,18 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
 	CopSTASH_set(PL_curcop,stash);
     }
 
-    cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
+    /* file becomes the CvFILE. For an XS, it's supposed to be 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.  So we cheat, and take advantage of the
+       fact that the first 0 bytes of any string always look the same.  */
+    cv = newXS(name, const_sv_xsub, file);
     CvXSUBANY(cv).any_ptr = sv;
     CvCONST_on(cv);
-    sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
+    /* prototype is "".  But this gets free()d.  :-)  */
+    sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL); 
+    /* This gives us a prototype of "", rather than the file name.  */
+    SvCUR_set(cv, 0);
 
 #ifdef USE_ITHREADS
     if (stash)
@@ -7209,6 +7232,7 @@ Perl_ck_subr(pTHX_ OP *o)
     OP *o2 = prev->op_sibling;
     OP *cvop;
     char *proto = NULL;
+    const char *proto_end = NULL;
     CV *cv = NULL;
     GV *namegv = NULL;
     int optional = 0;
@@ -7231,8 +7255,10 @@ Perl_ck_subr(pTHX_ OP *o)
 		tmpop->op_private |= OPpEARLY_CV;
 	    else {
 		if (SvPOK(cv)) {
+		    STRLEN len;
 		    namegv = CvANON(cv) ? gv : CvGV(cv);
-		    proto = SvPV_nolen((SV*)cv);
+		    proto = SvPV((SV*)cv, len);
+		    proto_end = proto + len;
 		}
 		if (CvASSERTION(cv)) {
 		    if (PL_hints & HINT_ASSERTING) {
@@ -7269,9 +7295,10 @@ Perl_ck_subr(pTHX_ OP *o)
 	else
 	    o3 = o2;
 	if (proto) {
-	    switch (*proto) {
-	    case '\0':
+	    if (proto >= proto_end)
 		return too_many_arguments(o, gv_ename(namegv));
+
+	    switch (*proto) {
 	    case ';':
 		optional = 1;
 		proto++;
@@ -7437,8 +7464,8 @@ Perl_ck_subr(pTHX_ OP *o)
 	prev = o2;
 	o2 = o2->op_sibling;
     } /* while */
-    if (proto && !optional &&
-	  (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
+    if (proto && !optional && proto_end > proto &&
+	(*proto != '@' && *proto != '%' && *proto != ';'))
 	return too_few_arguments(o, gv_ename(namegv));
     if(delete_op) {
 #ifdef PERL_MAD
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index ebc1c27880..225a5cbc09 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -2121,8 +2121,8 @@ X<savepvn>
 
 Perl's version of what C<strndup()> would be if it existed. Returns a
 pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
 
 	char*	savepvn(const char* pv, I32 len)
 
@@ -5758,7 +5758,7 @@ that pointer (e.g. ptr + 1) be used.
 
 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
-I<may> be skipped. (i.e. the buffer is actually at least 1 byte longer than
+will be skipped. (i.e. the buffer is actually at least 1 byte longer than
 C<len>, and already meets the requirements for storing in C<SvPVX>)
 
 	void	sv_usepvn_flags(SV* sv, char* ptr, STRLEN len, U32 flags)
diff --git a/proto.h b/proto.h
index 4808040f65..760caa1cf6 100644
--- a/proto.h
+++ b/proto.h
@@ -304,6 +304,9 @@ PERL_CALLCONV int	Perl_printf_nocontext(const char* fmt, ...)
 PERL_CALLCONV void	Perl_cv_ckproto(pTHX_ const CV* cv, const GV* gv, const char* p)
 			__attribute__nonnull__(pTHX_1);
 
+PERL_CALLCONV void	Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len)
+			__attribute__nonnull__(pTHX_1);
+
 PERL_CALLCONV CV*	Perl_cv_clone(pTHX_ CV* proto)
 			__attribute__nonnull__(pTHX_1);
 
diff --git a/sv.c b/sv.c
index e9f47ddff4..df5a5564e6 100644
--- a/sv.c
+++ b/sv.c
@@ -3309,8 +3309,9 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
 			}
 		    }
 		if (!intro)
-		    cv_ckproto(cv, (GV*)dstr,
-			       SvPOK(sref) ? SvPVX_const(sref) : NULL);
+		    cv_ckproto_len(cv, (GV*)dstr,
+				   SvPOK(sref) ? SvPVX_const(sref) : NULL,
+				   SvPOK(sref) ? SvCUR(sref) : 0);
 	    }
 	    GvCVGEN(dstr) = 0; /* Switch off cacheness. */
 	    GvASSUMECV_on(dstr);
@@ -3898,7 +3899,7 @@ that pointer (e.g. ptr + 1) be used.
 
 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
-I<may> be skipped. (i.e. the buffer is actually at least 1 byte longer than
+will be skipped. (i.e. the buffer is actually at least 1 byte longer than
 C<len>, and already meets the requirements for storing in C<SvPVX>)
 
 =cut
@@ -3925,20 +3926,21 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags)
 
     allocate = (flags & SV_HAS_TRAILING_NUL)
 	? len + 1: PERL_STRLEN_ROUNDUP(len + 1);
+    if (flags & SV_HAS_TRAILING_NUL) {
+	/* It's long enough - do nothing.
+	   Specfically Perl_newCONSTSUB is relying on this.  */
+    } else {
 #ifdef DEBUGGING
-    {
 	/* Force a move to shake out bugs in callers.  */
 	char *new_ptr = safemalloc(allocate);
 	Copy(ptr, new_ptr, len, char);
 	PoisonFree(ptr,len,char);
 	Safefree(ptr);
 	ptr = new_ptr;
-    }
 #else
-    if (!(flags & SV_HAS_TRAILING_NUL)) {
 	ptr = saferealloc (ptr, allocate);
-    }
 #endif
+    }
     SvPV_set(sv, ptr);
     SvCUR_set(sv, len);
     SvLEN_set(sv, allocate);
diff --git a/util.c b/util.c
index 18a5cd5d6e..285b8b8810 100644
--- a/util.c
+++ b/util.c
@@ -895,8 +895,8 @@ Perl_savepv(pTHX_ const char *pv)
 
 Perl's version of what C<strndup()> would be if it existed. Returns a
 pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
 
 =cut
 */