diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 18 | ||||
| -rw-r--r-- | ext/XS-APItest/t/mro.t | 16 | ||||
| -rw-r--r-- | mro.c | 23 |
4 files changed, 58 insertions, 0 deletions
@@ -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'; @@ -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. */ |