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.

1 files changed, 44 insertions, 4 deletions

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;
     }