From 02cab6748c4f3e4cc55324283a910fa275726a56 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Mon, 10 Oct 2011 23:31:55 -0700
Subject: [PATCH] [perl #94306] Do not skip first elem of linear isa
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

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.
---
 MANIFEST                  |  1 +
 ext/XS-APItest/APItest.xs | 18 ++++++++++++++++++
 ext/XS-APItest/t/mro.t    | 16 ++++++++++++++++
 mro.c                     | 23 +++++++++++++++++++++++
 4 files changed, 58 insertions(+)
 create mode 100644 ext/XS-APItest/t/mro.t

diff --git a/MANIFEST b/MANIFEST
index 00b95dd..a01e94b 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 4911f9a..27c587a 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 0000000..42dd661
--- /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 e0ab5bc..7f1bccc 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.  */
-- 
2.7.4