Proper pluggable Method Resolution Orders. 'c3' is now implemented outside the
authorNicholas Clark <nick@ccl4.org>
Sat, 27 Dec 2008 00:20:35 +0000 (00:20 +0000)
committerDavid Mitchell <davem@iabyn.com>
Mon, 30 Mar 2009 15:41:41 +0000 (16:41 +0100)
core, in ext/mro/mro.xs. Also move mro::_nextcan() to mro.xs. It needs direct
access to S_mro_get_linear_isa_c3(), and nothing on CPAN calls it, except via
methods defined in mro.pm. Hence all users already require mro;

(cherry picked from commit b2685f0c86badfc357584d8dbfb2bf17057ea226)

18 files changed:
.gitignore
MANIFEST
Makefile.SH
embed.fnc
embed.h
ext/mro/Changes [new file with mode: 0644]
ext/mro/Makefile.PL [new file with mode: 0644]
ext/mro/mro.pm [moved from lib/mro.pm with 98% similarity]
ext/mro/mro.xs [new file with mode: 0644]
ext/mro/t/pluggable.t [new file with mode: 0644]
hv.h
mro.c
proto.h
t/mro/basic.t
t/mro/inconsistent_c3.t
t/mro/recursion_c3.t
win32/Makefile
win32/makefile.mk

index 9a11832..4b430f9 100644 (file)
@@ -73,6 +73,7 @@ lib/App/
 lib/Archive/Tar/t/src/long/foo.tbz
 lib/Archive/Tar/t/src/short/foo.tbz
 lib/IPC/Cmd/t/src/x.tgz
+lib/mro.pm
 lib/TAP/
 lib/Test/Harness.pm
 t/rantests
index 150958f..29dda9d 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -921,6 +921,11 @@ ext/Module/Pluggable/lib/Devel/InnerPackage.pm             Find inner packages
 ext/Module/Pluggable/lib/Module/Pluggable/Object.pm    Module::Pluggable
 ext/Module/Pluggable/lib/Module/Pluggable.pm           Module::Pluggable
 ext/Module/Pluggable/Makefile.PL                       Module::Pluggable
+ext/mro/Changes                        mro extension
+ext/mro/Makefile.PL            mro extension
+ext/mro/mro.pm                 mro extension
+ext/mro/mro.xs                 mro extension
+ext/mro/t/pluggable.t          Test that c3 mro extension is actually pluggable
 ext/NDBM_File/hints/cygwin.pl  Hint for NDBM_File for named architecture
 ext/NDBM_File/hints/dec_osf.pl Hint for NDBM_File for named architecture
 ext/NDBM_File/hints/dynixptx.pl        Hint for NDBM_File for named architecture
@@ -2451,7 +2456,6 @@ lib/Module/Load/t/to_load/LoadMe.pl       Module::Load tests
 lib/Module/Load/t/to_load/Must/Be/Loaded.pm    Module::Load tests
 lib/Module/Load/t/to_load/TestModule.pm        Module::Load tests
 lib/Module/Load/t/to_load/ToBeLoaded   Module::Load tests
-lib/mro.pm                     mro extension
 lib/Net/Changes                        libnet
 lib/Net/Cmd.pm                 libnet
 lib/Net/Config.eg              libnet
index a4f8706..410f9db 100644 (file)
@@ -1251,6 +1251,7 @@ _cleaner2:
        rm -f preload lib/re.pm
        rm -rf lib/Encode lib/Compress lib/Hash lib/re
        rm -rf lib/TAP lib/Module/Pluggable lib/App
+       rm -rf lib/mro
        rm -rf lib/IO/Compress lib/IO/Uncompress
        rm -f lib/ExtUtils/ParseXS/t/XSTest.c
        rm -f lib/ExtUtils/ParseXS/t/XSTest$(OBJ_EXT)
index 3f6f7d7..13cd534 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2162,7 +2162,6 @@ p |struct mro_meta*       |mro_meta_dup   |NN struct mro_meta* smeta|NN CLONE_PARAMS* pa
 #endif
 Apd    |AV*    |mro_get_linear_isa|NN HV* stash
 #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT)
-sd     |AV*    |mro_get_linear_isa_c3|NN HV* stash|U32 level
 sd     |AV*    |mro_get_linear_isa_dfs|NN HV* stash|U32 level
 #endif
 : Used in hv.c, mg.c, pp.c, sv.c
diff --git a/embed.h b/embed.h
index 51b9e76..ee83839 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define mro_get_linear_isa     Perl_mro_get_linear_isa
 #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
-#define mro_get_linear_isa_c3  S_mro_get_linear_isa_c3
 #define mro_get_linear_isa_dfs S_mro_get_linear_isa_dfs
 #endif
 #endif
 #define mro_get_linear_isa(a)  Perl_mro_get_linear_isa(aTHX_ a)
 #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
-#define mro_get_linear_isa_c3(a,b)     S_mro_get_linear_isa_c3(aTHX_ a,b)
 #define mro_get_linear_isa_dfs(a,b)    S_mro_get_linear_isa_dfs(aTHX_ a,b)
 #endif
 #endif
diff --git a/ext/mro/Changes b/ext/mro/Changes
new file mode 100644 (file)
index 0000000..0dd224e
--- /dev/null
@@ -0,0 +1,6 @@
+Revision history for Perl extension mro.
+
+1.01  Fri Dec 26 19:23:01 2008
+       - original version; created by h2xs 1.23 with options
+               -b 5.10.0 -c -A -n mro --skip-ppport
+      Migrate code from the core's mro.c
diff --git a/ext/mro/Makefile.PL b/ext/mro/Makefile.PL
new file mode 100644 (file)
index 0000000..8ccd887
--- /dev/null
@@ -0,0 +1,10 @@
+use 5.010000;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+    NAME              => 'mro',
+    VERSION_FROM      => 'mro.pm', # finds $VERSION
+    ABSTRACT_FROM     => 'mro.pm', # retrieve abstract from module
+    MAN3PODS          => {},
+    AUTHOR            => 'Brandon L. Black <blblack@gmail.com>');
similarity index 98%
rename from lib/mro.pm
rename to ext/mro/mro.pm
index d4be79a..5f0ae96 100644 (file)
@@ -1,6 +1,7 @@
 #      mro.pm
 #
 #      Copyright (c) 2007 Brandon L Black
+#      Copyright (c) 2008 Larry Wall and others
 #
 #      You may distribute under the terms of either the GNU General Public
 #      License or the Artistic License, as specified in the README file.
@@ -11,7 +12,7 @@ use warnings;
 
 # mro.pm versions < 1.00 reserved for MRO::Compat
 #  for partial back-compat to 5.[68].x
-our $VERSION = '1.00';
+our $VERSION = '1.01';
 
 sub import {
     mro::set_mro(scalar(caller), $_[1]) if $_[1];
@@ -36,6 +37,9 @@ sub method {
     return;
 }
 
+require XSLoader;
+XSLoader::load('mro', $VERSION);
+
 1;
 
 __END__
diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs
new file mode 100644 (file)
index 0000000..30f0d11
--- /dev/null
@@ -0,0 +1,439 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+static AV*
+S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level);
+
+static const struct mro_alg c3_alg =
+    {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
+
+/*
+=for apidoc mro_get_linear_isa_c3
+
+Returns the C3 linearization of @ISA
+the given stash.  The return value is a read-only AV*.
+C<level> should be 0 (it is used internally in this
+function's recursion).
+
+You are responsible for C<SvREFCNT_inc()> on the
+return value if you plan to store it anywhere
+semi-permanently (otherwise it might be deleted
+out from under you the next time the cache is
+invalidated).
+
+=cut
+*/
+
+static AV*
+S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
+{
+    AV* retval;
+    GV** gvp;
+    GV* gv;
+    AV* isa;
+    const HEK* stashhek;
+    struct mro_meta* meta;
+
+    assert(HvAUX(stash));
+
+    stashhek = HvNAME_HEK(stash);
+    if (!stashhek)
+      Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
+
+    if (level > 100)
+        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
+                  HEK_KEY(stashhek));
+
+    meta = HvMROMETA(stash);
+
+    /* return cache if valid */
+    if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
+        return retval;
+    }
+
+    /* not in cache, make a new one */
+
+    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
+    isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
+
+    /* For a better idea how the rest of this works, see the much clearer
+       pure perl version in Algorithm::C3 0.01:
+       http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
+       (later versions go about it differently than this code for speed reasons)
+    */
+
+    if(isa && AvFILLp(isa) >= 0) {
+        SV** seqs_ptr;
+        I32 seqs_items;
+        HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
+        AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
+        I32* heads;
+
+        /* This builds @seqs, which is an array of arrays.
+           The members of @seqs are the MROs of
+           the members of @ISA, followed by @ISA itself.
+        */
+        I32 items = AvFILLp(isa) + 1;
+        SV** isa_ptr = AvARRAY(isa);
+        while(items--) {
+            SV* const isa_item = *isa_ptr++;
+            HV* const isa_item_stash = gv_stashsv(isa_item, 0);
+            if(!isa_item_stash) {
+                /* if no stash, make a temporary fake MRO
+                   containing just itself */
+                AV* const isa_lin = newAV();
+                av_push(isa_lin, newSVsv(isa_item));
+                av_push(seqs, MUTABLE_SV(isa_lin));
+            }
+            else {
+                /* recursion */
+                AV* const isa_lin
+                 = S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1);
+                av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
+            }
+        }
+        av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
+
+        /* This builds "heads", which as an array of integer array
+           indices, one per seq, which point at the virtual "head"
+           of the seq (initially zero) */
+        Newxz(heads, AvFILLp(seqs)+1, I32);
+
+        /* This builds %tails, which has one key for every class
+           mentioned in the tail of any sequence in @seqs (tail meaning
+           everything after the first class, the "head").  The value
+           is how many times this key appears in the tails of @seqs.
+        */
+        seqs_ptr = AvARRAY(seqs);
+        seqs_items = AvFILLp(seqs) + 1;
+        while(seqs_items--) {
+            AV *const seq = MUTABLE_AV(*seqs_ptr++);
+            I32 seq_items = AvFILLp(seq);
+            if(seq_items > 0) {
+                SV** seq_ptr = AvARRAY(seq) + 1;
+                while(seq_items--) {
+                    SV* const seqitem = *seq_ptr++;
+                   /* LVALUE fetch will create a new undefined SV if necessary
+                    */
+                    HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
+                    if(he) {
+                        SV* const val = HeVAL(he);
+                       /* This will increment undef to 1, which is what we
+                          want for a newly created entry.  */
+                        sv_inc(val);
+                    }
+                }
+            }
+        }
+
+        /* Initialize retval to build the return value in */
+        retval = newAV();
+        av_push(retval, newSVhek(stashhek)); /* us first */
+
+        /* This loop won't terminate until we either finish building
+           the MRO, or get an exception. */
+        while(1) {
+            SV* cand = NULL;
+            SV* winner = NULL;
+            int s;
+
+            /* "foreach $seq (@seqs)" */
+            SV** const avptr = AvARRAY(seqs);
+            for(s = 0; s <= AvFILLp(seqs); s++) {
+                SV** svp;
+                AV * const seq = MUTABLE_AV(avptr[s]);
+               SV* seqhead;
+                if(!seq) continue; /* skip empty seqs */
+                svp = av_fetch(seq, heads[s], 0);
+                seqhead = *svp; /* seqhead = head of this seq */
+                if(!winner) {
+                   HE* tail_entry;
+                   SV* val;
+                    /* if we haven't found a winner for this round yet,
+                       and this seqhead is not in tails (or the count
+                       for it in tails has dropped to zero), then this
+                       seqhead is our new winner, and is added to the
+                       final MRO immediately */
+                    cand = seqhead;
+                    if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
+                       && (val = HeVAL(tail_entry))
+                       && (SvIVX(val) > 0))
+                           continue;
+                    winner = newSVsv(cand);
+                    av_push(retval, winner);
+                    /* note however that even when we find a winner,
+                       we continue looping over @seqs to do housekeeping */
+                }
+                if(!sv_cmp(seqhead, winner)) {
+                    /* Once we have a winner (including the iteration
+                       where we first found him), inc the head ptr
+                       for any seq which had the winner as a head,
+                       NULL out any seq which is now empty,
+                       and adjust tails for consistency */
+
+                    const int new_head = ++heads[s];
+                    if(new_head > AvFILLp(seq)) {
+                        SvREFCNT_dec(avptr[s]);
+                        avptr[s] = NULL;
+                    }
+                    else {
+                       HE* tail_entry;
+                       SV* val;
+                        /* Because we know this new seqhead used to be
+                           a tail, we can assume it is in tails and has
+                           a positive value, which we need to dec */
+                        svp = av_fetch(seq, new_head, 0);
+                        seqhead = *svp;
+                        tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
+                        val = HeVAL(tail_entry);
+                        sv_dec(val);
+                    }
+                }
+            }
+
+            /* if we found no candidates, we are done building the MRO.
+               !cand means no seqs have any entries left to check */
+            if(!cand) {
+                Safefree(heads);
+                break;
+            }
+
+            /* If we had candidates, but nobody won, then the @ISA
+               hierarchy is not C3-incompatible */
+            if(!winner) {
+                /* we have to do some cleanup before we croak */
+
+                SvREFCNT_dec(retval);
+                Safefree(heads);
+
+                Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
+                    "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
+            }
+        }
+    }
+    else { /* @ISA was undefined or empty */
+        /* build a retval containing only ourselves */
+        retval = newAV();
+        av_push(retval, newSVhek(stashhek));
+    }
+
+    /* we don't want anyone modifying the cache entry but us,
+       and we do so by replacing it completely */
+    SvREADONLY_on(retval);
+
+    return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
+                                               MUTABLE_SV(retval)));
+    return retval;
+}
+
+
+/* These two are static helpers for next::method and friends,
+   and re-implement a bunch of the code from pp_caller() in
+   a more efficient manner for this particular usage.
+*/
+
+static I32
+__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
+    I32 i;
+    for (i = startingblock; i >= 0; i--) {
+        if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
+    }
+    return i;
+}
+
+MODULE = mro           PACKAGE = mro           PREFIX = mro
+
+void
+mro_nextcan(...)
+  PREINIT:
+    SV* self = ST(0);
+    const I32 throw_nomethod = SvIVX(ST(1));
+    register I32 cxix = cxstack_ix;
+    register const PERL_CONTEXT *ccstack = cxstack;
+    const PERL_SI *top_si = PL_curstackinfo;
+    HV* selfstash;
+    SV *stashname;
+    const char *fq_subname;
+    const char *subname;
+    STRLEN stashname_len;
+    STRLEN subname_len;
+    SV* sv;
+    GV** gvp;
+    AV* linear_av;
+    SV** linear_svp;
+    const char *hvname;
+    I32 entries;
+    struct mro_meta* selfmeta;
+    HV* nmcache;
+    I32 i;
+  PPCODE:
+    PERL_UNUSED_ARG(cv);
+
+    if(sv_isobject(self))
+        selfstash = SvSTASH(SvRV(self));
+    else
+        selfstash = gv_stashsv(self, GV_ADD);
+
+    assert(selfstash);
+
+    hvname = HvNAME_get(selfstash);
+    if (!hvname)
+        Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
+
+    /* This block finds the contextually-enclosing fully-qualified subname,
+       much like looking at (caller($i))[3] until you find a real sub that
+       isn't ANON, etc (also skips over pureperl next::method, etc) */
+    for(i = 0; i < 2; i++) {
+        cxix = __dopoptosub_at(ccstack, cxix);
+        for (;;) {
+           GV* cvgv;
+           STRLEN fq_subname_len;
+
+            /* we may be in a higher stacklevel, so dig down deeper */
+            while (cxix < 0) {
+                if(top_si->si_type == PERLSI_MAIN)
+                    Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
+                top_si = top_si->si_prev;
+                ccstack = top_si->si_cxstack;
+                cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
+            }
+
+            if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
+              || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
+                cxix = __dopoptosub_at(ccstack, cxix - 1);
+                continue;
+            }
+
+            {
+                const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
+                if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
+                    if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
+                        cxix = dbcxix;
+                        continue;
+                    }
+                }
+            }
+
+            cvgv = CvGV(ccstack[cxix].blk_sub.cv);
+
+            if(!isGV(cvgv)) {
+                cxix = __dopoptosub_at(ccstack, cxix - 1);
+                continue;
+            }
+
+            /* we found a real sub here */
+            sv = sv_2mortal(newSV(0));
+
+            gv_efullname3(sv, cvgv, NULL);
+
+            fq_subname = SvPVX(sv);
+            fq_subname_len = SvCUR(sv);
+
+            subname = strrchr(fq_subname, ':');
+            if(!subname)
+                Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
+
+            subname++;
+            subname_len = fq_subname_len - (subname - fq_subname);
+            if(subname_len == 8 && strEQ(subname, "__ANON__")) {
+                cxix = __dopoptosub_at(ccstack, cxix - 1);
+                continue;
+            }
+            break;
+        }
+        cxix--;
+    }
+
+    /* If we made it to here, we found our context */
+
+    /* Initialize the next::method cache for this stash
+       if necessary */
+    selfmeta = HvMROMETA(selfstash);
+    if(!(nmcache = selfmeta->mro_nextmethod)) {
+        nmcache = selfmeta->mro_nextmethod = newHV();
+    }
+    else { /* Use the cached coderef if it exists */
+       HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
+       if (cache_entry) {
+           SV* const val = HeVAL(cache_entry);
+           if(val == &PL_sv_undef) {
+               if(throw_nomethod)
+                   Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
+                XSRETURN_EMPTY;
+           }
+           mXPUSHs(newRV_inc(val));
+            XSRETURN(1);
+       }
+    }
+
+    /* beyond here is just for cache misses, so perf isn't as critical */
+
+    stashname_len = subname - fq_subname - 2;
+    stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
+
+    /* has ourselves at the top of the list */
+    linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
+
+    linear_svp = AvARRAY(linear_av);
+    entries = AvFILLp(linear_av) + 1;
+
+    /* Walk down our MRO, skipping everything up
+       to the contextually enclosing class */
+    while (entries--) {
+        SV * const linear_sv = *linear_svp++;
+        assert(linear_sv);
+        if(sv_eq(linear_sv, stashname))
+            break;
+    }
+
+    /* Now search the remainder of the MRO for the
+       same method name as the contextually enclosing
+       method */
+    if(entries > 0) {
+        while (entries--) {
+            SV * const linear_sv = *linear_svp++;
+           HV* curstash;
+           GV* candidate;
+           CV* cand_cv;
+
+            assert(linear_sv);
+            curstash = gv_stashsv(linear_sv, FALSE);
+
+            if (!curstash) {
+                if (ckWARN(WARN_SYNTAX))
+                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
+                        (void*)linear_sv, hvname);
+                continue;
+            }
+
+            assert(curstash);
+
+            gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
+            if (!gvp) continue;
+
+            candidate = *gvp;
+            assert(candidate);
+
+            if (SvTYPE(candidate) != SVt_PVGV)
+                gv_init(candidate, curstash, subname, subname_len, TRUE);
+
+            /* Notably, we only look for real entries, not method cache
+               entries, because in C3 the method cache of a parent is not
+               valid for the child */
+            if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
+                SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
+                (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
+                mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
+                XSRETURN(1);
+            }
+        }
+    }
+
+    (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
+    if(throw_nomethod)
+        Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
+    XSRETURN_EMPTY;
+
+BOOT:
+    Perl_mro_register(aTHX_ &c3_alg);
diff --git a/ext/mro/t/pluggable.t b/ext/mro/t/pluggable.t
new file mode 100644 (file)
index 0000000..be3fe06
--- /dev/null
@@ -0,0 +1,26 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+{
+  package A;
+}
+
+@B::ISA = 'A';
+@C::ISA = 'A';
+@D::ISA = qw(B C);
+
+eval {mro::set_mro('D', 'c3')};
+
+like $@, qr/Invalid mro name: 'c3'/;
+
+require mro;
+
+is_deeply(mro::get_linear_isa('D'), [qw(D B A C)], 'still dfs MRO');
+
+mro::set_mro('D', 'c3');
+
+is_deeply(mro::get_linear_isa('D'), [qw(D B C A)], 'c3 MRO');
diff --git a/hv.h b/hv.h
index 912152c..3c16a38 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -41,9 +41,13 @@ struct shared_he {
    Use the funcs in mro.c
 */
 
-
-/* structure may change, so not public yet */
-struct mro_alg;
+struct mro_alg {
+    AV *(*resolve)(pTHX_ HV* stash, U32 level);
+    const char *name;
+    U16 length;
+    U16        kflags; /* For the hash API - set HVhek_UTF8 if name is UTF-8 */
+    U32 hash; /* or 0 */
+};
 
 struct mro_meta {
     /* repurposed as a hash holding the different MROs private data. */
diff --git a/mro.c b/mro.c
index e1836a3..150c03c 100644 (file)
--- a/mro.c
+++ b/mro.c
@@ -27,21 +27,9 @@ These functions are related to the method resolution order of perl classes
 #define PERL_IN_MRO_C
 #include "perl.h"
 
-struct mro_alg {
-    AV *(*resolve)(pTHX_ HV* stash, U32 level);
-    const char *name;
-    U16 length;
-    U16        kflags; /* For the hash API - set HVhek_UTF8 if name is UTF-8 */
-    U32 hash; /* or 0 */
-};
-
 static const struct mro_alg dfs_alg =
     {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
 
-static const struct mro_alg c3_alg =
-    {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
-
-
 SV *
 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
                          const struct mro_alg *const which)
@@ -356,225 +344,6 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
                                                MUTABLE_SV(retval)));
 }
 
-/*
-=for apidoc mro_get_linear_isa_c3
-
-Returns the C3 linearization of @ISA
-the given stash.  The return value is a read-only AV*.
-C<level> should be 0 (it is used internally in this
-function's recursion).
-
-You are responsible for C<SvREFCNT_inc()> on the
-return value if you plan to store it anywhere
-semi-permanently (otherwise it might be deleted
-out from under you the next time the cache is
-invalidated).
-
-=cut
-*/
-
-static AV*
-S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
-{
-    AV* retval;
-    GV** gvp;
-    GV* gv;
-    AV* isa;
-    const HEK* stashhek;
-    struct mro_meta* meta;
-
-    PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
-    assert(HvAUX(stash));
-
-    stashhek = HvNAME_HEK(stash);
-    if (!stashhek)
-      Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
-
-    if (level > 100)
-        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
-                  HEK_KEY(stashhek));
-
-    meta = HvMROMETA(stash);
-
-    /* return cache if valid */
-    if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
-        return retval;
-    }
-
-    /* not in cache, make a new one */
-
-    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
-    isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
-
-    /* For a better idea how the rest of this works, see the much clearer
-       pure perl version in Algorithm::C3 0.01:
-       http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
-       (later versions go about it differently than this code for speed reasons)
-    */
-
-    if(isa && AvFILLp(isa) >= 0) {
-        SV** seqs_ptr;
-        I32 seqs_items;
-        HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
-        AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
-        I32* heads;
-
-        /* This builds @seqs, which is an array of arrays.
-           The members of @seqs are the MROs of
-           the members of @ISA, followed by @ISA itself.
-        */
-        I32 items = AvFILLp(isa) + 1;
-        SV** isa_ptr = AvARRAY(isa);
-        while(items--) {
-            SV* const isa_item = *isa_ptr++;
-            HV* const isa_item_stash = gv_stashsv(isa_item, 0);
-            if(!isa_item_stash) {
-                /* if no stash, make a temporary fake MRO
-                   containing just itself */
-                AV* const isa_lin = newAV();
-                av_push(isa_lin, newSVsv(isa_item));
-                av_push(seqs, MUTABLE_SV(isa_lin));
-            }
-            else {
-                /* recursion */
-                AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
-                av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
-            }
-        }
-        av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
-
-        /* This builds "heads", which as an array of integer array
-           indices, one per seq, which point at the virtual "head"
-           of the seq (initially zero) */
-        Newxz(heads, AvFILLp(seqs)+1, I32);
-
-        /* This builds %tails, which has one key for every class
-           mentioned in the tail of any sequence in @seqs (tail meaning
-           everything after the first class, the "head").  The value
-           is how many times this key appears in the tails of @seqs.
-        */
-        seqs_ptr = AvARRAY(seqs);
-        seqs_items = AvFILLp(seqs) + 1;
-        while(seqs_items--) {
-            AV *const seq = MUTABLE_AV(*seqs_ptr++);
-            I32 seq_items = AvFILLp(seq);
-            if(seq_items > 0) {
-                SV** seq_ptr = AvARRAY(seq) + 1;
-                while(seq_items--) {
-                    SV* const seqitem = *seq_ptr++;
-                   /* LVALUE fetch will create a new undefined SV if necessary
-                    */
-                    HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
-                    if(he) {
-                        SV* const val = HeVAL(he);
-                       /* This will increment undef to 1, which is what we
-                          want for a newly created entry.  */
-                        sv_inc(val);
-                    }
-                }
-            }
-        }
-
-        /* Initialize retval to build the return value in */
-        retval = newAV();
-        av_push(retval, newSVhek(stashhek)); /* us first */
-
-        /* This loop won't terminate until we either finish building
-           the MRO, or get an exception. */
-        while(1) {
-            SV* cand = NULL;
-            SV* winner = NULL;
-            int s;
-
-            /* "foreach $seq (@seqs)" */
-            SV** const avptr = AvARRAY(seqs);
-            for(s = 0; s <= AvFILLp(seqs); s++) {
-                SV** svp;
-                AV * const seq = MUTABLE_AV(avptr[s]);
-               SV* seqhead;
-                if(!seq) continue; /* skip empty seqs */
-                svp = av_fetch(seq, heads[s], 0);
-                seqhead = *svp; /* seqhead = head of this seq */
-                if(!winner) {
-                   HE* tail_entry;
-                   SV* val;
-                    /* if we haven't found a winner for this round yet,
-                       and this seqhead is not in tails (or the count
-                       for it in tails has dropped to zero), then this
-                       seqhead is our new winner, and is added to the
-                       final MRO immediately */
-                    cand = seqhead;
-                    if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
-                       && (val = HeVAL(tail_entry))
-                       && (SvIVX(val) > 0))
-                           continue;
-                    winner = newSVsv(cand);
-                    av_push(retval, winner);
-                    /* note however that even when we find a winner,
-                       we continue looping over @seqs to do housekeeping */
-                }
-                if(!sv_cmp(seqhead, winner)) {
-                    /* Once we have a winner (including the iteration
-                       where we first found him), inc the head ptr
-                       for any seq which had the winner as a head,
-                       NULL out any seq which is now empty,
-                       and adjust tails for consistency */
-
-                    const int new_head = ++heads[s];
-                    if(new_head > AvFILLp(seq)) {
-                        SvREFCNT_dec(avptr[s]);
-                        avptr[s] = NULL;
-                    }
-                    else {
-                       HE* tail_entry;
-                       SV* val;
-                        /* Because we know this new seqhead used to be
-                           a tail, we can assume it is in tails and has
-                           a positive value, which we need to dec */
-                        svp = av_fetch(seq, new_head, 0);
-                        seqhead = *svp;
-                        tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
-                        val = HeVAL(tail_entry);
-                        sv_dec(val);
-                    }
-                }
-            }
-
-            /* if we found no candidates, we are done building the MRO.
-               !cand means no seqs have any entries left to check */
-            if(!cand) {
-                Safefree(heads);
-                break;
-            }
-
-            /* If we had candidates, but nobody won, then the @ISA
-               hierarchy is not C3-incompatible */
-            if(!winner) {
-                /* we have to do some cleanup before we croak */
-
-                SvREFCNT_dec(retval);
-                Safefree(heads);
-
-                Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
-                    "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
-            }
-        }
-    }
-    else { /* @ISA was undefined or empty */
-        /* build a retval containing only ourselves */
-        retval = newAV();
-        av_push(retval, newSVhek(stashhek));
-    }
-
-    /* we don't want anyone modifying the cache entry but us,
-       and we do so by replacing it completely */
-    SvREADONLY_on(retval);
-
-    return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
-                                               MUTABLE_SV(retval)));
-    return retval;
-}
-
 /*
 =for apidoc mro_get_linear_isa
 
@@ -816,20 +585,6 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
     }
 }
 
-/* These two are static helpers for next::method and friends,
-   and re-implement a bunch of the code from pp_caller() in
-   a more efficient manner for this particular usage.
-*/
-
-STATIC I32
-__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
-    I32 i;
-    for (i = startingblock; i >= 0; i--) {
-        if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
-    }
-    return i;
-}
-
 #include "XSUB.h"
 
 XS(XS_mro_get_linear_isa);
@@ -840,7 +595,6 @@ XS(XS_mro_is_universal);
 XS(XS_mro_invalidate_method_caches);
 XS(XS_mro_method_changed_in);
 XS(XS_mro_get_pkg_gen);
-XS(XS_mro_nextcan);
 
 void
 Perl_boot_core_mro(pTHX)
@@ -849,7 +603,6 @@ Perl_boot_core_mro(pTHX)
     static const char file[] = __FILE__;
 
     Perl_mro_register(aTHX_ &dfs_alg);
-    Perl_mro_register(aTHX_ &c3_alg);
 
     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
@@ -859,7 +612,6 @@ Perl_boot_core_mro(pTHX)
     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
-    newXS("mro::_nextcan", XS_mro_nextcan, file);
 }
 
 XS(XS_mro_get_linear_isa) {
@@ -1067,200 +819,6 @@ XS(XS_mro_get_pkg_gen)
     return;
 }
 
-XS(XS_mro_nextcan)
-{
-    dVAR;
-    dXSARGS;
-    SV* self = ST(0);
-    const I32 throw_nomethod = SvIVX(ST(1));
-    register I32 cxix = cxstack_ix;
-    register const PERL_CONTEXT *ccstack = cxstack;
-    const PERL_SI *top_si = PL_curstackinfo;
-    HV* selfstash;
-    SV *stashname;
-    const char *fq_subname;
-    const char *subname;
-    STRLEN stashname_len;
-    STRLEN subname_len;
-    SV* sv;
-    GV** gvp;
-    AV* linear_av;
-    SV** linear_svp;
-    const char *hvname;
-    I32 entries;
-    struct mro_meta* selfmeta;
-    HV* nmcache;
-    I32 i;
-
-    PERL_UNUSED_ARG(cv);
-
-    SP -= items;
-
-    if(sv_isobject(self))
-        selfstash = SvSTASH(SvRV(self));
-    else
-        selfstash = gv_stashsv(self, GV_ADD);
-
-    assert(selfstash);
-
-    hvname = HvNAME_get(selfstash);
-    if (!hvname)
-        Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
-
-    /* This block finds the contextually-enclosing fully-qualified subname,
-       much like looking at (caller($i))[3] until you find a real sub that
-       isn't ANON, etc (also skips over pureperl next::method, etc) */
-    for(i = 0; i < 2; i++) {
-        cxix = __dopoptosub_at(ccstack, cxix);
-        for (;;) {
-           GV* cvgv;
-           STRLEN fq_subname_len;
-
-            /* we may be in a higher stacklevel, so dig down deeper */
-            while (cxix < 0) {
-                if(top_si->si_type == PERLSI_MAIN)
-                    Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
-                top_si = top_si->si_prev;
-                ccstack = top_si->si_cxstack;
-                cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
-            }
-
-            if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
-              || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
-                cxix = __dopoptosub_at(ccstack, cxix - 1);
-                continue;
-            }
-
-            {
-                const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
-                if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
-                    if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
-                        cxix = dbcxix;
-                        continue;
-                    }
-                }
-            }
-
-            cvgv = CvGV(ccstack[cxix].blk_sub.cv);
-
-            if(!isGV(cvgv)) {
-                cxix = __dopoptosub_at(ccstack, cxix - 1);
-                continue;
-            }
-
-            /* we found a real sub here */
-            sv = sv_2mortal(newSV(0));
-
-            gv_efullname3(sv, cvgv, NULL);
-
-            fq_subname = SvPVX(sv);
-            fq_subname_len = SvCUR(sv);
-
-            subname = strrchr(fq_subname, ':');
-            if(!subname)
-                Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
-
-            subname++;
-            subname_len = fq_subname_len - (subname - fq_subname);
-            if(subname_len == 8 && strEQ(subname, "__ANON__")) {
-                cxix = __dopoptosub_at(ccstack, cxix - 1);
-                continue;
-            }
-            break;
-        }
-        cxix--;
-    }
-
-    /* If we made it to here, we found our context */
-
-    /* Initialize the next::method cache for this stash
-       if necessary */
-    selfmeta = HvMROMETA(selfstash);
-    if(!(nmcache = selfmeta->mro_nextmethod)) {
-        nmcache = selfmeta->mro_nextmethod = newHV();
-    }
-    else { /* Use the cached coderef if it exists */
-       HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
-       if (cache_entry) {
-           SV* const val = HeVAL(cache_entry);
-           if(val == &PL_sv_undef) {
-               if(throw_nomethod)
-                   Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
-                XSRETURN_EMPTY;
-           }
-           mXPUSHs(newRV_inc(val));
-            XSRETURN(1);
-       }
-    }
-
-    /* beyond here is just for cache misses, so perf isn't as critical */
-
-    stashname_len = subname - fq_subname - 2;
-    stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
-
-    linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
-
-    linear_svp = AvARRAY(linear_av);
-    entries = AvFILLp(linear_av) + 1;
-
-    /* Walk down our MRO, skipping everything up
-       to the contextually enclosing class */
-    while (entries--) {
-        SV * const linear_sv = *linear_svp++;
-        assert(linear_sv);
-        if(sv_eq(linear_sv, stashname))
-            break;
-    }
-
-    /* Now search the remainder of the MRO for the
-       same method name as the contextually enclosing
-       method */
-    if(entries > 0) {
-        while (entries--) {
-            SV * const linear_sv = *linear_svp++;
-           HV* curstash;
-           GV* candidate;
-           CV* cand_cv;
-
-            assert(linear_sv);
-            curstash = gv_stashsv(linear_sv, FALSE);
-
-            if (!curstash) {
-                if (ckWARN(WARN_SYNTAX))
-                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
-                        (void*)linear_sv, hvname);
-                continue;
-            }
-
-            assert(curstash);
-
-            gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
-            if (!gvp) continue;
-
-            candidate = *gvp;
-            assert(candidate);
-
-            if (SvTYPE(candidate) != SVt_PVGV)
-                gv_init(candidate, curstash, subname, subname_len, TRUE);
-
-            /* Notably, we only look for real entries, not method cache
-               entries, because in C3 the method cache of a parent is not
-               valid for the child */
-            if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
-                SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
-                (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
-                mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
-                XSRETURN(1);
-            }
-        }
-    }
-
-    (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
-    if(throw_nomethod)
-        Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
-    XSRETURN_EMPTY;
-}
-
 /*
  * Local variables:
  * c-indentation-style: bsd
diff --git a/proto.h b/proto.h
index bff12ad..83daccf 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6606,11 +6606,6 @@ PERL_CALLCONV AV*        Perl_mro_get_linear_isa(pTHX_ HV* stash)
        assert(stash)
 
 #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT)
-STATIC AV*     S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
-                       __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3 \
-       assert(stash)
-
 STATIC AV*     S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS        \
index 6dce364..e066226 100644 (file)
@@ -5,6 +5,8 @@ use warnings;
 
 require q(./test.pl); plan(tests => 40);
 
+require mro;
+
 {
     package MRO_A;
     our @ISA = qw//;
index 14f652c..68d3795 100644 (file)
@@ -11,6 +11,8 @@ BEGIN {
 
 require q(./test.pl); plan(tests => 1);
 
+require mro;
+
 =pod
 
 This example is take from: http://www.python.org/2.3/mro.html
index 4030cfc..cc45250 100644 (file)
@@ -14,6 +14,8 @@ require './test.pl';
 plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
 plan(tests => 8);
 
+require mro;
+
 =pod
 
 These are like the 010_complex_merge_classless test,
index 8a9d255..576320b 100644 (file)
@@ -1186,6 +1186,7 @@ distclean: realclean
        -if exist $(LIBDIR)\App rmdir /s /q $(LIBDIR)\App
        -if exist $(LIBDIR)\Module\Pluggable rmdir /s /q $(LIBDIR)\Module\Pluggable
        -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP
+       -if exist $(LIBDIR)\mro rmdir /s /q $(LIBDIR)\mro
        -if exist $(LIBDIR)\IO\Compress rmdir /s /q $(LIBDIR)\IO\Compress
        -if exist $(LIBDIR)\IO\Socket rmdir /s /q $(LIBDIR)\IO\Socket
        -if exist $(LIBDIR)\IO\Uncompress rmdir /s /q $(LIBDIR)\IO\Uncompress
index ad49421..9fd2303 100644 (file)
@@ -1510,6 +1510,7 @@ distclean: realclean
        -if exist $(LIBDIR)\App rmdir /s /q $(LIBDIR)\App
        -if exist $(LIBDIR)\Module\Pluggable rmdir /s /q $(LIBDIR)\Module\Pluggable
        -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP
+       -if exist $(LIBDIR)\mro rmdir /s /q $(LIBDIR)\mro
        -if exist $(LIBDIR)\IO\Compress rmdir /s /q $(LIBDIR)\IO\Compress
        -if exist $(LIBDIR)\IO\Socket rmdir /s /q $(LIBDIR)\IO\Socket
        -if exist $(LIBDIR)\IO\Uncompress rmdir /s /q $(LIBDIR)\IO\Uncompress