[perl #94306] Do not skip first elem of linear isa

Perl has assumed up till now that the first element of an isa linear-
isation is the name of the class itself.  That is true for dfs and c3,
but not requiring that makes it easier for plugin authors.

Since various parts of the mro code make that assumption, this commit
copies the AV returned by mro_alg.resolve to a new one beginning with
the class’s own name, if the original AV did not include it.

4 files changed, 58 insertions, 0 deletions

diff --git a/MANIFEST b/MANIFEST
index 00b95dd8b0..a01e94bfe9 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3845,6 +3845,7 @@ ext/XS-APItest/t/lvalue.t	Test XS lvalue functions
 ext/XS-APItest/t/magic_chain.t	test low-level MAGIC chain handling
 ext/XS-APItest/t/magic.t	test attaching, finding, and removing magic
 ext/XS-APItest/t/Markers.pm	Helper for ./blockhooks.t
+ext/XS-APItest/t/mro.t		Test mro plugin api
 ext/XS-APItest/t/multicall.t	XS::APItest: test MULTICALL macros
 ext/XS-APItest/t/my_cxt.t	XS::APItest: test MY_CXT interface
 ext/XS-APItest/t/my_exit.t	XS::APItest: test my_exit
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 4911f9aba2..27c587af58 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1063,11 +1063,23 @@ filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
     return SvCUR(buf_sv);
 }
 
+static AV *
+myget_linear_isa(pTHX_ HV *stash, U32 level) {
+    PERL_UNUSED_ARG(level);
+    GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0);
+    return gvp && *gvp && GvAV(*gvp)
+	 ? GvAV(*gvp)
+	 : (AV *)sv_2mortal((SV *)newAV());
+}
+
 
 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
 
+static struct mro_alg mymro;
+
+
 #include "const-c.inc"
 
 MODULE = XS::APItest		PACKAGE = XS::APItest
@@ -1143,6 +1155,12 @@ BOOT:
     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
     newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
     newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
+    mymro.resolve = myget_linear_isa;
+    mymro.name    = "justinc";
+    mymro.length  = 7;
+    mymro.kflags  = 0;
+    mymro.hash    = 0;
+    Perl_mro_register(aTHX_ &mymro);
 
 void
 XS_VERSION_defined(...)
diff --git a/ext/XS-APItest/t/mro.t b/ext/XS-APItest/t/mro.t
new file mode 100644
index 0000000000..42dd6614e4
--- /dev/null
+++ b/ext/XS-APItest/t/mro.t
@@ -0,0 +1,16 @@
+#!perl
+
+use XS::APItest;
+use Test::More;
+
+plan tests => 1;
+
+use mro;
+mro::set_mro(AA => 'justinc');
+
+@AA::ISA = qw "BB CC";
+
+sub BB::fromp { "bb" }
+sub CC::fromp { "cc" }
+
+is fromp AA, 'bb', 'first elem of linearisation is not ignored';
diff --git a/mro.c b/mro.c
index e0ab5bc96c..7f1bccc450 100644
--- a/mro.c
+++ b/mro.c
@@ -413,6 +413,29 @@ Perl_mro_get_linear_isa(pTHX_ HV *stash)
         Perl_croak(aTHX_ "panic: invalid MRO!");
     isa = meta->mro_which->resolve(aTHX_ stash, 0);
 
+    if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
+	SV * const namesv =
+	    (HvENAME(stash)||HvNAME(stash))
+	      ? newSVhek(HvENAME_HEK(stash)
+			  ? HvENAME_HEK(stash)
+			  : HvNAME_HEK(stash))
+	      : NULL;
+
+	if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
+	{
+	    AV * const old = isa;
+	    SV **svp;
+	    SV **ovp = AvARRAY(old);
+	    SV * const * const oend = ovp + AvFILLp(old) + 1;
+	    isa = (AV *)sv_2mortal((SV *)newAV());
+	    av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
+	    *AvARRAY(isa) = namesv;
+	    svp = AvARRAY(isa)+1;
+	    while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
+	}
+	else SvREFCNT_dec(namesv);
+    }
+
     if (!meta->isa) {
 	    HV *const isa_hash = newHV();
 	    /* Linearisation didn't build it for us, so do it here.  */