Resolve XS AUTOLOAD-prototype conflict

Did you know that a subroutine’s prototype can be modified with s///?
Don’t look:

    *AUTOLOAD = *Internals'SvREFCNT;
    my $f = "Just another "; eval{main->$f};
    print prototype AUTOLOAD;
    $f =~ s/Just another /Perl hacker,\n/;
    print prototype AUTOLOAD;

You did look, didn’t you?  You must admit that’s creepy.

The problem goes back to this:

commit adb5a9ae91a0bed93d396bb0abda99831f9e2e6f
Author: Doug MacEachern <dougm@covalent.net>
Date:   Sat Jan 6 01:30:05 2001 -0800

    [patch] xsub AUTOLOAD fix/optimization
    Message-ID: <Pine.LNX.4.10.10101060924280.24460-100000@mojo.covalent.net>

    Allow AUTOLOAD to be an xsub and allow such xsubs
    to avoid use of $AUTOLOAD.

    p4raw-id: //depot/perl@8362

which includes this:

+    if (CvXSUB(cv)) {
+        /* rather than lookup/init $AUTOLOAD here
+         * only to have the XSUB do another lookup for $AUTOLOAD
+         * and split that value on the last '::',
+         * pass along the same data via some unused fields in the CV
+         */
+        CvSTASH(cv) = stash;
+        SvPVX(cv) = (char *)name; /* cast to loose constness warning */
+        SvCUR(cv) = len;
+        return gv;
+    }

That ‘unused’ field is not unused.  It’s where the prototype is
stored.  So, not only is it clobbering the prototype, it’s also leak-
ing it by assigning over the top of SvPVX.  Furthermore, it’s blindly
assigning someone else’s string, which could be freed before it’s
even used.

Since it has been documented for a long time that SvPVX contains the
name of the AUTOLOADed sub, and since the use of SvPVX for prototypes
is documented nowhere, we have to preserve the former.

So this commit makes the prototype and the sub name share the same
buffer, in a manner resembling that which CvFILE used before I changed
it with bad4ae38.

There are two new internal macros, CvPROTO and CvPROTOLEN for retriev-
ing the prototype.

8 files changed, 158 insertions, 16 deletions

diff --git a/cv.h b/cv.h
index f47d171908..ebc876a540 100644
--- a/cv.h
+++ b/cv.h
@@ -71,6 +71,23 @@ For more information, see L<perlguts>.
 #define CvFLAGS(sv)	((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_flags
 #define CvOUTSIDE_SEQ(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside_seq
 
+/* These two are sometimes called on non-CVs */
+#define CvPROTO(sv)                               \
+	(                                          \
+	 SvPOK(sv)                                  \
+	  ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \
+	     ? SvEND(sv)+1 : SvPVX_const(sv)          \
+	  : NULL                                       \
+	)
+#define CvPROTOLEN(sv)	                          \
+	(                                          \
+	 SvPOK(sv)                                  \
+	  ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \
+	     ? SvLEN(sv)-SvCUR(sv)-2                  \
+	     : SvCUR(sv)                               \
+	  : 0                                           \
+	)
+
 #define CVf_METHOD	0x0001	/* CV is explicitly marked as a method */
 #define CVf_LVALUE	0x0002  /* CV return value can be used as lvalue */
 #define CVf_CONST	0x0004  /* inlinable sub */
@@ -86,6 +103,7 @@ For more information, see L<perlguts>.
 				   (esp. useful for special XSUBs) */
 #define CVf_CVGV_RC	0x0400	/* CvGV is reference counted */
 #define CVf_DYNFILE	0x1000	/* The filename isn't static  */
+#define CVf_AUTOLOAD	0x2000	/* SvPVX contains AUTOLOADed sub name  */
 
 /* This symbol for optimised communication between toke.c and op.c: */
 #define CVf_BUILTIN_ATTRS	(CVf_METHOD|CVf_LVALUE)
@@ -147,6 +165,10 @@ For more information, see L<perlguts>.
 #define CvDYNFILE_on(cv)	(CvFLAGS(cv) |= CVf_DYNFILE)
 #define CvDYNFILE_off(cv)	(CvFLAGS(cv) &= ~CVf_DYNFILE)
 
+#define CvAUTOLOAD(cv)		(CvFLAGS(cv) & CVf_AUTOLOAD)
+#define CvAUTOLOAD_on(cv)	(CvFLAGS(cv) |= CVf_AUTOLOAD)
+#define CvAUTOLOAD_off(cv)	(CvFLAGS(cv) &= ~CVf_AUTOLOAD)
+
 /* Flags for newXS_flags  */
 #define XS_DYNAMIC_FILENAME	0x01	/* The filename isn't static  */
 
diff --git a/dump.c b/dump.c
index 3281031213..ca4e03dccf 100644
--- a/dump.c
+++ b/dump.c
@@ -1442,6 +1442,7 @@ const struct flag_to_name cv_flags_names[] = {
     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
     {CVf_CVGV_RC, "CVGV_RC,"},
     {CVf_DYNFILE, "DYNFILE,"},
+    {CVf_AUTOLOAD, "AUTOLOAD,"},
     {CVf_ISXSUB, "ISXSUB,"}
 };
 
@@ -1954,11 +1955,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	break;
 
     case SVt_PVCV:
-	if (SvPOK(sv)) {
+	if (CvAUTOLOAD(sv)) {
 	    STRLEN len;
-	    const char *const proto =  SvPV_const(sv, len);
+	    const char *const name =  SvPV_const(sv, len);
+	    Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%.*s\"\n",
+			     (int) len, name);
+	}
+	if (SvPOK(sv)) {
 	    Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
-			     (int) len, proto);
+			     (int) CvPROTOLEN(sv), CvPROTO(sv));
 	}
 	/* FALL THROUGH */
     case SVt_PVFM:
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 96efeb4cfd..4911f9aba2 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1526,6 +1526,14 @@ AUTOLOAD()
     OUTPUT:
 	RETVAL
 
+SV *
+AUTOLOADp(...)
+    PROTOTYPE: *$
+    CODE:
+	RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
+    OUTPUT:
+	RETVAL
+
 
 MODULE = XS::APItest		PACKAGE = XS::APItest
 
diff --git a/ext/XS-APItest/t/autoload.t b/ext/XS-APItest/t/autoload.t
index dd89c501a0..46564077b2 100644
--- a/ext/XS-APItest/t/autoload.t
+++ b/ext/XS-APItest/t/autoload.t
@@ -1,9 +1,13 @@
 #!perl
 
+# This script tests not only the interface for XS AUTOLOAD routines to find
+# out the sub name, but also that that interface does not interfere with
+# prototypes, the way it did before 5.15.4.
+
 use strict;
 use warnings;
 
-use Test::More tests => 3;
+use Test::More tests => 14;
 
 use XS::APItest;
 
@@ -12,3 +16,46 @@ is "XS::APItest::AutoLoader::fr\0b"->(), "fr\0b",
   'name with embedded null passed to XS AUTOLOAD';
 is "XS::APItest::AutoLoader::fr\x{1ed9}b"->(), "fr\x{1ed9}b",
   'Unicode name passed to XS AUTOLOAD';
+
+*AUTOLOAD = *XS::APItest::AutoLoader::AUTOLOADp;
+
+is frob(), 'frob', 'name passed to XS AUTOLOAD with proto';
+is prototype \&AUTOLOAD, '*$', 'prototype is unchanged';
+is "fr\0b"->(), "fr\0b",
+  'name with embedded null passed to XS AUTOLOAD with proto';
+is prototype \&AUTOLOAD, '*$', 'proto unchanged after embedded-null call';
+is "fr\x{1ed9}b"->(), "fr\x{1ed9}b",
+  'Unicode name passed to XS AUTOLOAD with proto';
+is prototype \&AUTOLOAD, '*$', 'prototype is unchanged after Unicode call';
+
+# Test that the prototype was preserved from the parser’s point of view
+
+ok !eval "sub { ::AUTOLOAD(1) }",
+   'parse failure due to AUTOLOAD prototype';
+ok eval "sub { ::AUTOLOAD(1,2) }", 'successful parse respecting prototype'
+  or diag $@;
+
+package fribble { sub a { return 7 } }
+no warnings 'once';
+*a = \&AUTOLOAD;
+'$'->();
+# &a('fribble') will return '$'
+# But if intuit_method does not see the (*...) proto, this compiles as
+# fribble->a
+no strict;
+is eval 'a fribble, 3', '$', 'intuit_method sees * in AUTOLOAD proto'
+  or diag $@;
+
+# precedence check
+# *$ should parse as a list operator, but right now the AUTOLOAD
+# sub name is $
+is join(" ", eval 'a "b", "c"'), '$',
+   'precedence determination respects prototype of AUTOLOAD sub';
+
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w .= shift };
+    eval 'sub a($){}';
+    like $w, qr/^Prototype mismatch: sub main::a \(\*\$\) vs \(\$\)/m,
+        'proto warnings respect AUTOLOAD prototypes';
+}
diff --git a/gv.c b/gv.c
index 684f279737..22d78c7664 100644
--- a/gv.c
+++ b/gv.c
@@ -1172,13 +1172,53 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
         /* rather than lookup/init $AUTOLOAD here
          * only to have the XSUB do another lookup for $AUTOLOAD
          * and split that value on the last '::',
-         * pass along the same data via some unused fields in the CV
+         * pass along the same data via the SvPVX field in the CV
+         *
+         * Due to an unfortunate accident of history, the SvPVX field
+         * serves two purposes.  It is also used for the subroutine’s pro-
+         * type.  Since SvPVX has been documented as returning the sub name
+         * for a long time, but not as returning the prototype, we have
+         * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
+         * elsewhere.
+         *
+         * We put the prototype in the same allocated buffer, but after
+         * the sub name.  The SvPOK flag indicates the presence of a proto-
+         * type.  The CvAUTOLOAD flag indicates the presence of a sub name.
+         * If both flags are on, then SvLEN is used to indicate the end of
+         * the prototype (artificially lower than what is actually allo-
+         * cated), at the risk of having to reallocate a few bytes unneces-
+         * sarily--but that should happen very rarely, if ever.
+         *
+         * We use SvUTF8 for both prototypes and sub names, so if one is
+         * UTF8, the other must be upgraded.
          */
 	CvSTASH_set(cv, stash);
-        SvPV_set(cv, (char *)name); /* cast to lose constness warning */
-        SvCUR_set(cv, len);
-        if (is_utf8)
+	if (SvPOK(cv)) { /* Ouch! */
+	    SV *tmpsv = newSVpvn_flags(name, len, is_utf8);
+	    STRLEN ulen;
+	    const char *proto = CvPROTO(cv);
+	    assert(proto);
+	    if (SvUTF8(cv))
+		sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
+	    ulen = SvCUR(tmpsv);
+	    SvCUR(tmpsv)++; /* include null in string */
+	    sv_catpvn_flags(
+		tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
+	    );
+	    SvTEMP_on(tmpsv); /* Allow theft */
+	    sv_setsv_nomg((SV *)cv, tmpsv);
+	    SvREFCNT_dec(tmpsv);
+	    SvLEN(cv) = SvCUR(cv) + 1;
+	    SvCUR(cv) = ulen;
+	}
+	else {
+	  sv_setpvn((SV *)cv, name, len);
+	  SvPOK_off(cv);
+	  if (is_utf8)
             SvUTF8_on(cv);
+	  else SvUTF8_off(cv);
+	}
+	CvAUTOLOAD_on(cv);
         return gv;
     }
 
diff --git a/op.c b/op.c
index 939b47869d..40053e5766 100644
--- a/op.c
+++ b/op.c
@@ -6250,9 +6250,23 @@ void
 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
 		    const STRLEN len, const U32 flags)
 {
+    const char * const cvp = CvPROTO(cv);
+    const STRLEN clen = CvPROTOLEN(cv);
+
     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
-    if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
-        || (p && !sv_eq((SV*)cv, newSVpvn_flags(p, len, flags | SVs_TEMP))))
+
+    if (((!p != !cvp) /* One has prototype, one has not.  */
+	|| (p && (
+		  (flags & SVf_UTF8) == SvUTF8(cv)
+		   ? len != clen || memNE(cvp, p, len)
+		   : flags & SVf_UTF8
+		      ? bytes_cmp_utf8((const U8 *)cvp, clen,
+				       (const U8 *)p, len)
+		      : bytes_cmp_utf8((const U8 *)p, len,
+				       (const U8 *)cvp, clen)
+		 )
+	   )
+        )
 	 && ckWARN_d(WARN_PROTOTYPE)) {
 	SV* const msg = sv_newmortal();
 	SV* name = NULL;
@@ -6263,7 +6277,9 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
 	if (name)
 	    Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
 	if (SvPOK(cv))
-	    Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
+	    Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
+		SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
+	    );
 	else
 	    sv_catpvs(msg, ": none");
 	sv_catpvs(msg, " vs ");
@@ -8997,7 +9013,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
 	Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
-    proto = SvPV(protosv, proto_len);
+    if (SvTYPE(protosv) == SVt_PVCV)
+	 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
+    else proto = SvPV(protosv, proto_len);
     proto_end = proto + proto_len;
     aop = cUNOPx(entersubop)->op_first;
     if (!aop->op_sibling)
diff --git a/pp.c b/pp.c
index 40cb3dee13..6d403ea643 100644
--- a/pp.c
+++ b/pp.c
@@ -457,7 +457,9 @@ PP(pp_prototype)
     }
     cv = sv_2cv(TOPs, &stash, &gv, 0);
     if (cv && SvPOK(cv))
-	ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv));
+	ret = newSVpvn_flags(
+	    CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
+	);
   set:
     SETs(ret);
     RETURN;
diff --git a/toke.c b/toke.c
index 755b8b4ecc..47ad80490b 100644
--- a/toke.c
+++ b/toke.c
@@ -3739,7 +3739,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
 	    return 0;
 	if (cv) {
 	    if (SvPOK(cv)) {
-		const char *proto = SvPVX_const(cv);
+		const char *proto = CvPROTO(cv);
 		if (proto) {
 		    if (*proto == ';')
 			proto++;
@@ -6775,8 +6775,8 @@ Perl_yylex(pTHX)
 #endif
 			SvPOK(cv))
 		    {
-			STRLEN protolen;
-			const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
+			STRLEN protolen = CvPROTOLEN(cv);
+			const char *proto = CvPROTO(cv);
 			if (!protolen)
 			    TERM(FUNC0SUB);
 			while (*proto == ';')