Proper pluggable Method Resolution Orders. 'c3' is now implemented outside the

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;

5 files changed, 863 insertions, 0 deletions

diff --git a/ext/mro/Changes b/ext/mro/Changes
new file mode 100644
index 0000000000..0dd224e18a
--- /dev/null
+++ b/ext/mro/Changes
@@ -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
index 0000000000..8ccd8873fb
--- /dev/null
+++ b/ext/mro/Makefile.PL
@@ -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>');
diff --git a/ext/mro/mro.pm b/ext/mro/mro.pm
new file mode 100644
index 0000000000..5f0ae9683e
--- /dev/null
+++ b/ext/mro/mro.pm
@@ -0,0 +1,382 @@
+#      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.
+#
+package mro;
+use strict;
+use warnings;
+
+# mro.pm versions < 1.00 reserved for MRO::Compat
+#  for partial back-compat to 5.[68].x
+our $VERSION = '1.01';
+
+sub import {
+    mro::set_mro(scalar(caller), $_[1]) if $_[1];
+}
+
+package # hide me from PAUSE
+    next;
+
+sub can { mro::_nextcan($_[0], 0) }
+
+sub method {
+    my $method = mro::_nextcan($_[0], 1);
+    goto &$method;
+}
+
+package # hide me from PAUSE
+    maybe::next;
+
+sub method {
+    my $method = mro::_nextcan($_[0], 0);
+    goto &$method if defined $method;
+    return;
+}
+
+require XSLoader;
+XSLoader::load('mro', $VERSION);
+
+1;
+
+__END__
+
+=head1 NAME
+
+mro - Method Resolution Order
+
+=head1 SYNOPSIS
+
+  use mro; # enables next::method and friends globally
+
+  use mro 'dfs'; # enable DFS MRO for this class (Perl default)
+  use mro 'c3'; # enable C3 MRO for this class
+
+=head1 DESCRIPTION
+
+The "mro" namespace provides several utilities for dealing
+with method resolution order and method caching in general.
+
+These interfaces are only available in Perl 5.9.5 and higher.
+See L<MRO::Compat> on CPAN for a mostly forwards compatible
+implementation for older Perls.
+
+=head1 OVERVIEW
+
+It's possible to change the MRO of a given class either by using C<use
+mro> as shown in the synopsis, or by using the L</mro::set_mro> function
+below.  The functions in the mro namespace do not require loading the
+C<mro> module, as they are actually provided by the core perl interpreter.
+
+The special methods C<next::method>, C<next::can>, and
+C<maybe::next::method> are not available until this C<mro> module
+has been loaded via C<use> or C<require>.
+
+=head1 The C3 MRO
+
+In addition to the traditional Perl default MRO (depth first
+search, called C<DFS> here), Perl now offers the C3 MRO as
+well.  Perl's support for C3 is based on the work done in
+Stevan Little's module L<Class::C3>, and most of the C3-related
+documentation here is ripped directly from there.
+
+=head2 What is C3?
+
+C3 is the name of an algorithm which aims to provide a sane method
+resolution order under multiple inheritance. It was first introduced in
+the language Dylan (see links in the L</"SEE ALSO"> section), and then
+later adopted as the preferred MRO (Method Resolution Order) for the
+new-style classes in Python 2.3. Most recently it has been adopted as the
+"canonical" MRO for Perl 6 classes, and the default MRO for Parrot objects
+as well.
+
+=head2 How does C3 work
+
+C3 works by always preserving local precendence ordering. This essentially
+means that no class will appear before any of its subclasses. Take, for
+instance, the classic diamond inheritance pattern:
+
+     <A>
+    /   \
+  <B>   <C>
+    \   /
+     <D>
+
+The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A>
+appears before B<C>, even though B<C> is the subclass of B<A>. The C3 MRO
+algorithm however, produces the following order: (D, B, C, A), which does
+not have this issue.
+
+This example is fairly trivial; for more complex cases and a deeper
+explanation, see the links in the L</"SEE ALSO"> section.
+
+=head1 Functions
+
+=head2 mro::get_linear_isa($classname[, $type])
+
+Returns an arrayref which is the linearized MRO of the given class.
+Uses whichever MRO is currently in effect for that class by default,
+or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
+
+The linearized MRO of a class is an ordered array of all of the
+classes one would search when resolving a method on that class,
+starting with the class itself.
+
+If the requested class doesn't yet exist, this function will still
+succeed, and return C<[ $classname ]>
+
+Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
+part of the MRO of a class, even though all classes implicitly inherit
+methods from C<UNIVERSAL> and its parents.
+
+=head2 mro::set_mro($classname, $type)
+
+Sets the MRO of the given class to the C<$type> argument (either
+C<c3> or C<dfs>).
+
+=head2 mro::get_mro($classname)
+
+Returns the MRO of the given class (either C<c3> or C<dfs>).
+
+=head2 mro::get_isarev($classname)
+
+Gets the C<mro_isarev> for this class, returned as an
+arrayref of class names.  These are every class that "isa"
+the given class name, even if the isa relationship is
+indirect.  This is used internally by the MRO code to
+keep track of method/MRO cache invalidations.
+
+Currently, this list only grows, it never shrinks.  This
+was a performance consideration (properly tracking and
+deleting isarev entries when someone removes an entry
+from an C<@ISA> is costly, and it doesn't happen often
+anyways).  The fact that a class which no longer truly
+"isa" this class at runtime remains on the list should be
+considered a quirky implementation detail which is subject
+to future change.  It shouldn't be an issue as long as
+you're looking at this list for the same reasons the
+core code does: as a performance optimization
+over having to search every class in existence.
+
+As with C<mro::get_mro> above, C<UNIVERSAL> is special.
+C<UNIVERSAL> (and parents') isarev lists do not include
+every class in existence, even though all classes are
+effectively descendants for method inheritance purposes.
+
+=head2 mro::is_universal($classname)
+
+Returns a boolean status indicating whether or not
+the given classname is either C<UNIVERSAL> itself,
+or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
+
+Any class for which this function returns true is
+"universal" in the sense that all classes potentially
+inherit methods from it.
+
+For similar reasons to C<isarev> above, this flag is
+permanent.  Once it is set, it does not go away, even
+if the class in question really isn't universal anymore.
+
+=head2 mro::invalidate_all_method_caches()
+
+Increments C<PL_sub_generation>, which invalidates method
+caching in all packages.
+
+=head2 mro::method_changed_in($classname)
+
+Invalidates the method cache of any classes dependent on the
+given class.  This is not normally necessary.  The only
+known case where pure perl code can confuse the method
+cache is when you manually install a new constant
+subroutine by using a readonly scalar value, like the
+internals of L<constant> do.  If you find another case,
+please report it so we can either fix it or document
+the exception here.
+
+=head2 mro::get_pkg_gen($classname)
+
+Returns an integer which is incremented every time a
+real local method in the package C<$classname> changes,
+or the local C<@ISA> of C<$classname> is modified.
+
+This is intended for authors of modules which do lots
+of class introspection, as it allows them to very quickly
+check if anything important about the local properties
+of a given class have changed since the last time they
+looked.  It does not increment on method/C<@ISA>
+changes in superclasses.
+
+It's still up to you to seek out the actual changes,
+and there might not actually be any.  Perhaps all
+of the changes since you last checked cancelled each
+other out and left the package in the state it was in
+before.
+
+This integer normally starts off at a value of C<1>
+when a package stash is instantiated.  Calling it
+on packages whose stashes do not exist at all will
+return C<0>.  If a package stash is completely
+deleted (not a normal occurence, but it can happen
+if someone does something like C<undef %PkgName::>),
+the number will be reset to either C<0> or C<1>,
+depending on how completely package was wiped out.
+
+=head2 next::method
+
+This is somewhat like C<SUPER>, but it uses the C3 method
+resolution order to get better consistency in multiple
+inheritance situations.  Note that while inheritance in
+general follows whichever MRO is in effect for the
+given class, C<next::method> only uses the C3 MRO.
+
+One generally uses it like so:
+
+  sub some_method {
+    my $self = shift;
+    my $superclass_answer = $self->next::method(@_);
+    return $superclass_answer + 1;
+  }
+
+Note that you don't (re-)specify the method name.
+It forces you to always use the same method name
+as the method you started in.
+
+It can be called on an object or a class, of course.
+
+The way it resolves which actual method to call is:
+
+=over 4
+
+=item 1
+
+First, it determines the linearized C3 MRO of
+the object or class it is being called on.
+
+=item 2
+
+Then, it determines the class and method name
+of the context it was invoked from.
+
+=item 3
+
+Finally, it searches down the C3 MRO list until
+it reaches the contextually enclosing class, then
+searches further down the MRO list for the next
+method with the same name as the contextually
+enclosing method.
+
+=back
+
+Failure to find a next method will result in an
+exception being thrown (see below for alternatives).
+
+This is substantially different than the behavior
+of C<SUPER> under complex multiple inheritance.
+(This becomes obvious when one realizes that the
+common superclasses in the C3 linearizations of
+a given class and one of its parents will not
+always be ordered the same for both.)
+
+B<Caveat>: Calling C<next::method> from methods defined outside the class:
+
+There is an edge case when using C<next::method> from within a subroutine
+which was created in a different module than the one it is called from. It
+sounds complicated, but it really isn't. Here is an example which will not
+work correctly:
+
+  *Foo::foo = sub { (shift)->next::method(@_) };
+
+The problem exists because the anonymous subroutine being assigned to the
+C<*Foo::foo> glob will show up in the call stack as being called
+C<__ANON__> and not C<foo> as you might expect. Since C<next::method> uses
+C<caller> to find the name of the method it was called in, it will fail in
+this case. 
+
+But fear not, there's a simple solution. The module C<Sub::Name> will
+reach into the perl internals and assign a name to an anonymous subroutine
+for you. Simply do this:
+
+  use Sub::Name 'subname';
+  *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
+
+and things will Just Work.
+
+=head2 next::can
+
+This is similar to C<next::method>, but just returns either a code
+reference or C<undef> to indicate that no further methods of this name
+exist.
+
+=head2 maybe::next::method
+
+In simple cases, it is equivalent to:
+
+   $self->next::method(@_) if $self->next::can;
+
+But there are some cases where only this solution
+works (like C<goto &maybe::next::method>);
+
+=head1 SEE ALSO
+
+=head2 The original Dylan paper
+
+=over 4
+
+=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
+
+=back
+
+=head2 The prototype Perl 6 Object Model uses C3
+
+=over 4
+
+=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
+
+=back
+
+=head2 Parrot now uses C3
+
+=over 4
+
+=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
+
+=item L<http://use.perl.org/~autrijus/journal/25768>
+
+=back
+
+=head2 Python 2.3 MRO related links
+
+=over 4
+
+=item L<http://www.python.org/2.3/mro.html>
+
+=item L<http://www.python.org/2.2.2/descrintro.html#mro>
+
+=back
+
+=head2 C3 for TinyCLOS
+
+=over 4
+
+=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
+
+=back 
+
+=head2 Class::C3
+
+=over 4
+
+=item L<Class::C3>
+
+=back
+
+=head1 AUTHOR
+
+Brandon L. Black, E<lt>blblack@gmail.comE<gt>
+
+Based on Stevan Little's L<Class::C3>
+
+=cut
diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs
new file mode 100644
index 0000000000..30f0d11302
--- /dev/null
+++ b/ext/mro/mro.xs
@@ -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
index 0000000000..be3fe060fc
--- /dev/null
+++ b/ext/mro/t/pluggable.t
@@ -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');