This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #94306] Do not skip first elem of linear isa
authorFather Chrysostomos <sprout@cpan.org>
Tue, 11 Oct 2011 06:31:55 +0000 (23:31 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 11 Oct 2011 06:42:18 +0000 (23:42 -0700)
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
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/mro.t [new file with mode: 0644]
mro.c

index 00b95dd..a01e94b 100644 (file)
--- 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
index 4911f9a..27c587a 100644 (file)
@@ -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 (file)
index 0000000..42dd661
--- /dev/null
@@ -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 (file)
--- 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.  */