This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: new C3 MRO patch
authorBrandon Black <blblack@gmail.com>
Tue, 17 Apr 2007 13:14:36 +0000 (08:14 -0500)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Thu, 19 Apr 2007 14:48:20 +0000 (14:48 +0000)
From: "Brandon Black" <blblack@gmail.com>
Message-ID: <84621a60704171114k29b0460el5b08ce5185d55ed5@mail.gmail.com>

p4raw-id: //depot/perl@30980

60 files changed:
MANIFEST
Makefile.SH
Makefile.micro
NetWare/Makefile
embed.fnc
embed.h
ext/B/t/b.t
global.sym
gv.c
hv.c
hv.h
lib/constant.pm
lib/mro.pm [new file with mode: 0644]
lib/overload.pm
mg.c
mro.c [new file with mode: 0644]
op.c
perl.c
pod/perlapi.pod
pp_hot.c
proto.h
scope.c
sv.c
t/TEST
t/mro/basic.t [new file with mode: 0644]
t/mro/basic_01_c3.t [new file with mode: 0644]
t/mro/basic_01_dfs.t [new file with mode: 0644]
t/mro/basic_02_c3.t [new file with mode: 0644]
t/mro/basic_02_dfs.t [new file with mode: 0644]
t/mro/basic_03_c3.t [new file with mode: 0644]
t/mro/basic_03_dfs.t [new file with mode: 0644]
t/mro/basic_04_c3.t [new file with mode: 0644]
t/mro/basic_04_dfs.t [new file with mode: 0644]
t/mro/basic_05_c3.t [new file with mode: 0644]
t/mro/basic_05_dfs.t [new file with mode: 0644]
t/mro/c3_with_overload.t [new file with mode: 0644]
t/mro/complex_c3.t [new file with mode: 0644]
t/mro/complex_dfs.t [new file with mode: 0644]
t/mro/dbic_c3.t [new file with mode: 0644]
t/mro/dbic_dfs.t [new file with mode: 0644]
t/mro/inconsistent_c3.t [new file with mode: 0644]
t/mro/method_caching.t [new file with mode: 0644]
t/mro/next_method.t [new file with mode: 0644]
t/mro/next_method_edge_cases.t [new file with mode: 0644]
t/mro/next_method_in_anon.t [new file with mode: 0644]
t/mro/next_method_in_eval.t [new file with mode: 0644]
t/mro/next_method_skip.t [new file with mode: 0644]
t/mro/next_method_used_with_NEXT.t [new file with mode: 0644]
t/mro/overload_c3.t [new file with mode: 0644]
t/mro/overload_dfs.t [new file with mode: 0644]
t/mro/recursion_c3.t [new file with mode: 0644]
t/mro/recursion_dfs.t [new file with mode: 0644]
t/mro/vulcan_c3.t [new file with mode: 0644]
t/mro/vulcan_dfs.t [new file with mode: 0644]
t/op/magic.t
universal.c
vms/descrip_mms.template
win32/Makefile
win32/Makefile.ce
win32/makefile.mk

index 31aac08..53510ae 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2252,6 +2252,7 @@ lib/Module/Pluggable/t/lib/No/Middle.pm   Module::Pluggable tests
 lib/Module/Pluggable/t/lib/OddTest/Plugin/-Dodgy.pm    Module::Pluggable tests
 lib/Module/Pluggable/t/lib/OddTest/Plugin/Foo.pm       Module::Pluggable tests
 lib/Module/Pluggable/t/lib/TA/C/A/I.pm Module::Pluggable tests
+lib/mro.pm                     mro extension
 lib/Net/Changes.libnet         libnet
 lib/Net/Cmd.pm                 libnet
 lib/Net/Config.eg              libnet
@@ -2955,6 +2956,7 @@ mpeix/mpeixish.h          MPE/iX port
 mpeix/mpeix_setjmp.c           MPE/iX port
 mpeix/nm                       MPE/iX port
 mpeix/relink                   MPE/iX port
+mro.c                          Method Resolution Order code
 myconfig.SH                    Prints summary of the current configuration
 NetWare/bat/Buildtype.bat      NetWare port
 NetWare/bat/SetCodeWar.bat     NetWare port
@@ -3621,6 +3623,36 @@ t/lib/warnings/toke              Tests for toke.c for warnings.t
 t/lib/warnings/universal       Tests for universal.c for warnings.t
 t/lib/warnings/utf8            Tests for utf8.c for warnings.t
 t/lib/warnings/util            Tests for util.c for warnings.t
+t/mro/basic_01_c3.t            mro tests
+t/mro/basic_01_dfs.t           mro tests
+t/mro/basic_02_c3.t            mro tests
+t/mro/basic_02_dfs.t           mro tests
+t/mro/basic_03_c3.t            mro tests
+t/mro/basic_03_dfs.t           mro tests
+t/mro/basic_04_c3.t            mro tests
+t/mro/basic_04_dfs.t           mro tests
+t/mro/basic_05_c3.t            mro tests
+t/mro/basic_05_dfs.t           mro tests
+t/mro/basic.t                  mro tests
+t/mro/c3_with_overload.t       mro tests
+t/mro/complex_c3.t             mro tests
+t/mro/complex_dfs.t            mro tests
+t/mro/dbic_c3.t                        mro tests
+t/mro/dbic_dfs.t               mro tests
+t/mro/inconsistent_c3.t                mro tests
+t/mro/method_caching.t         mro tests
+t/mro/next_method_edge_cases.t mro tests
+t/mro/next_method_in_anon.t    mro tests
+t/mro/next_method_in_eval.t    mro tests
+t/mro/next_method_skip.t       mro tests
+t/mro/next_method.t            mro tests
+t/mro/next_method_used_with_NEXT.t     mro tests
+t/mro/overload_c3.t            mro tests
+t/mro/overload_dfs.t           mro tests
+t/mro/recursion_c3.t           mro tests
+t/mro/recursion_dfs.t          mro tests
+t/mro/vulcan_c3.t              mro tests
+t/mro/vulcan_dfs.t             mro tests
 Todo.micro                     The Wishlist for microperl
 toke.c                         The tokener
 t/op/64bitint.t                        See if 64 bit integers work
index 76aa4d1..5d51410 100644 (file)
@@ -367,7 +367,7 @@ h4 = regexp.h scope.h sv.h unixish.h util.h iperlsys.h thread.h
 h5 = utf8.h warnings.h
 h = $(h1) $(h2) $(h3) $(h4) $(h5)
 
-c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c  perl.c
+c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c mro.c perl.c
 c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c
 c3 = taint.c toke.c util.c deb.c run.c universal.c xsutils.c pad.c globals.c
 c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c
@@ -375,7 +375,7 @@ c5 = $(madlysrc) $(mallocsrc)
 
 c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c perlmain.c opmini.c
 
-obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT)
+obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro$(OBJ_EXT)
 obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) perl$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
 obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT)
 
index 61a758e..b851edb 100644 (file)
@@ -10,7 +10,7 @@ PERL = perl
 all:   microperl
 
 O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \
-       uglobals$(_O) ugv$(_O) uhv$(_O) \
+       uglobals$(_O) ugv$(_O) uhv$(_O) umro$(_O)\
        umg$(_O) uperlmain$(_O) uop$(_O) ureentr$(_O) \
        upad$(_O) uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \
        upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) upp_sort$(_O) \
@@ -76,6 +76,9 @@ uglobals$(_O):        $(H) globals.c INTERN.h perlapi.h
 ugv$(_O):      $(HE) gv.c
        $(CC) -c -o $@ $(CFLAGS) gv.c
 
+umro$(_O):     $(HE) mro.c
+       $(CC) -c -o $@ $(CFLAGS) mro.c
+
 uhv$(_O):      $(HE) hv.c
        $(CC) -c -o $@ $(CFLAGS) hv.c
 
index f6ae9b7..bc0609c 100644 (file)
@@ -701,6 +701,7 @@ MICROCORE_SRC       =               \
                ..\dump.c       \
                ..\globals.c    \
                ..\gv.c         \
+               ..\mro.c        \
                ..\hv.c         \
                ..\locale.c     \
                 ..\mathoms.c    \
index ba2616a..688aae2 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -282,6 +282,16 @@ Ap |void   |gv_efullname4  |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|boo
 Ap     |GV*    |gv_fetchfile   |NN const char* name
 Ap     |GV*    |gv_fetchfile_flags|NN const char *const name|const STRLEN len\
                                |const U32 flags
+ApM    |struct mro_meta*       |mro_meta_init  |NN HV* stash
+#if defined(USE_ITHREADS)
+ApM    |struct mro_meta*       |mro_meta_dup   |NN struct mro_meta* smeta|NN CLONE_PARAMS* param
+#endif
+ApM    |AV*    |mro_get_linear_isa|NN HV* stash
+ApM    |AV*    |mro_get_linear_isa_c3|NN HV* stash|I32 level
+ApM    |AV*    |mro_get_linear_isa_dfs|NN HV* stash|I32 level
+ApM    |void   |mro_isa_changed_in|NN HV* stash
+ApM    |void   |mro_method_changed_in  |NN HV* stash
+ApM    |void   |boot_core_mro
 Apd    |GV*    |gv_fetchmeth   |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
 Apd    |GV*    |gv_fetchmeth_autoload  |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
 Apdmb  |GV*    |gv_fetchmethod |NULLOK HV* stash|NN const char* name
diff --git a/embed.h b/embed.h
index e02e844..97a2500 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define gv_efullname4          Perl_gv_efullname4
 #define gv_fetchfile           Perl_gv_fetchfile
 #define gv_fetchfile_flags     Perl_gv_fetchfile_flags
+#define mro_meta_init          Perl_mro_meta_init
+#if defined(USE_ITHREADS)
+#define mro_meta_dup           Perl_mro_meta_dup
+#endif
+#define mro_get_linear_isa     Perl_mro_get_linear_isa
+#define mro_get_linear_isa_c3  Perl_mro_get_linear_isa_c3
+#define mro_get_linear_isa_dfs Perl_mro_get_linear_isa_dfs
+#define mro_isa_changed_in     Perl_mro_isa_changed_in
+#define mro_method_changed_in  Perl_mro_method_changed_in
+#define boot_core_mro          Perl_boot_core_mro
 #define gv_fetchmeth           Perl_gv_fetchmeth
 #define gv_fetchmeth_autoload  Perl_gv_fetchmeth_autoload
 #define gv_fetchmethod_autoload        Perl_gv_fetchmethod_autoload
 #define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d)
 #define gv_fetchfile(a)                Perl_gv_fetchfile(aTHX_ a)
 #define gv_fetchfile_flags(a,b,c)      Perl_gv_fetchfile_flags(aTHX_ a,b,c)
+#define mro_meta_init(a)       Perl_mro_meta_init(aTHX_ a)
+#if defined(USE_ITHREADS)
+#define mro_meta_dup(a,b)      Perl_mro_meta_dup(aTHX_ a,b)
+#endif
+#define mro_get_linear_isa(a)  Perl_mro_get_linear_isa(aTHX_ a)
+#define mro_get_linear_isa_c3(a,b)     Perl_mro_get_linear_isa_c3(aTHX_ a,b)
+#define mro_get_linear_isa_dfs(a,b)    Perl_mro_get_linear_isa_dfs(aTHX_ a,b)
+#define mro_isa_changed_in(a)  Perl_mro_isa_changed_in(aTHX_ a)
+#define mro_method_changed_in(a)       Perl_mro_method_changed_in(aTHX_ a)
+#define boot_core_mro()                Perl_boot_core_mro(aTHX)
 #define gv_fetchmeth(a,b,c,d)  Perl_gv_fetchmeth(aTHX_ a,b,c,d)
 #define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
 #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
index b750f12..e0e21f4 100755 (executable)
@@ -169,7 +169,7 @@ is(B::opnumber("chop"), 38, "Testing opnumber with opname (chop)");
 {
     no warnings 'once';
     my $sg = B::sub_generation();
-    *Whatever::hand_waving = sub { };
+    *UNIVERSAL::hand_waving = sub { };
     ok( $sg < B::sub_generation, "sub_generation increments" );
 }
 
index 57405d0..0d83614 100644 (file)
@@ -135,6 +135,14 @@ Perl_gv_efullname3
 Perl_gv_efullname4
 Perl_gv_fetchfile
 Perl_gv_fetchfile_flags
+Perl_mro_meta_init
+Perl_mro_meta_dup
+Perl_mro_get_linear_isa
+Perl_mro_get_linear_isa_c3
+Perl_mro_get_linear_isa_dfs
+Perl_mro_isa_changed_in
+Perl_mro_method_changed_in
+Perl_boot_core_mro
 Perl_gv_fetchmeth
 Perl_gv_fetchmeth_autoload
 Perl_gv_fetchmethod
diff --git a/gv.c b/gv.c
index 963f0ae..53b25b6 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -260,7 +260,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
        }
        LEAVE;
 
-       PL_sub_generation++;
+        mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
        CvGV(GvCV(gv)) = gv;
        CvFILE_set_from_cop(GvCV(gv), PL_curcop);
        CvSTASH(GvCV(gv)) = PL_curstash;
@@ -310,7 +310,7 @@ accessible via @ISA and UNIVERSAL::.
 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 side-effect creates a glob with the given C<name> in the given C<stash>
 which in the case of success contains an alias for the subroutine, and sets
-up caching info for this glob.  Similarly for all the searched stashes.
+up caching info for this glob.
 
 This function grants C<"SUPER"> token as a postfix of the stash name. The
 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
@@ -321,133 +321,148 @@ obtained from the GV with the C<GvCV> macro.
 =cut
 */
 
+/* NOTE: No support for tied ISA */
+
 GV *
 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 {
     dVAR;
-    AV* av;
-    GV* topgv;
-    GV* gv;
     GV** gvp;
-    CV* cv;
+    AV* linear_av;
+    SV** linear_svp;
+    SV* linear_sv;
+    HV* cstash;
+    GV* candidate = NULL;
+    CV* cand_cv = NULL;
+    CV* old_cv;
+    GV* topgv = NULL;
     const char *hvname;
-    HV* lastchance = NULL;
+    I32 create = (level >= 0) ? 1 : 0;
+    I32 items;
+    STRLEN packlen;
+    U32 topgen_cmp;
 
     /* UNIVERSAL methods should be callable without a stash */
     if (!stash) {
-       level = -1;  /* probably appropriate */
+       create = 0;  /* probably appropriate */
        if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
            return 0;
     }
 
+    assert(stash);
+
     hvname = HvNAME_get(stash);
     if (!hvname)
-      Perl_croak(aTHX_
-                "Can't use anonymous symbol table for method lookup");
+      Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 
-    if ((level > 100) || (level < -100))
-       Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
-             name, hvname);
+    assert(hvname);
+    assert(name);
 
     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
 
-    gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
-    if (!gvp)
-       topgv = NULL;
-    else {
-       topgv = *gvp;
-       if (SvTYPE(topgv) != SVt_PVGV)
-           gv_init(topgv, stash, name, len, TRUE);
-       if ((cv = GvCV(topgv))) {
-           /* If genuine method or valid cache entry, use it */
-           if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
-               return topgv;
-           /* Stale cached entry: junk it */
-           SvREFCNT_dec(cv);
-           GvCV(topgv) = cv = NULL;
-           GvCVGEN(topgv) = 0;
-       }
-       else if (GvCVGEN(topgv) == PL_sub_generation)
-           return 0;  /* cache indicates sub doesn't exist */
+    topgen_cmp = HvMROMETA(stash)->sub_generation + PL_sub_generation;
+
+    /* check locally for a real method or a cache entry */
+    gvp = (GV**)hv_fetch(stash, name, len, create);
+    if(gvp) {
+        topgv = *gvp;
+        assert(topgv);
+        if (SvTYPE(topgv) != SVt_PVGV)
+            gv_init(topgv, stash, name, len, TRUE);
+        if ((cand_cv = GvCV(topgv))) {
+            /* If genuine method or valid cache entry, use it */
+            if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
+                return topgv;
+            }
+            else {
+                /* stale cache entry, junk it and move on */
+               SvREFCNT_dec(cand_cv);
+               GvCV(topgv) = cand_cv = NULL;
+               GvCVGEN(topgv) = 0;
+            }
+        }
+        else if (GvCVGEN(topgv) == topgen_cmp) {
+            /* cache indicates no such method definitively */
+            return 0;
+        }
     }
 
-    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
-    av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
-
-    /* create and re-create @.*::SUPER::ISA on demand */
-    if (!av || !SvMAGIC(av)) {
-       STRLEN packlen = HvNAMELEN_get(stash);
-
-       if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
-           HV* basestash;
-
-           packlen -= 7;
-           basestash = gv_stashpvn(hvname, packlen, GV_ADD);
-           gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
-           if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
-               gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
-               if (!gvp || !(gv = *gvp))
-                   Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
-               if (SvTYPE(gv) != SVt_PVGV)
-                   gv_init(gv, stash, "ISA", 3, TRUE);
-               SvREFCNT_dec(GvAV(gv));
-               GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
-           }
-       }
+    packlen = HvNAMELEN_get(stash);
+    if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
+        HV* basestash;
+        packlen -= 7;
+        basestash = gv_stashpvn(hvname, packlen, GV_ADD);
+        linear_av = mro_get_linear_isa(basestash);
     }
-
-    if (av) {
-       SV** svp = AvARRAY(av);
-       /* NOTE: No support for tied ISA */
-       I32 items = AvFILLp(av) + 1;
-       while (items--) {
-           SV* const sv = *svp++;
-           HV* const basestash = gv_stashsv(sv, 0);
-           if (!basestash) {
-               if (ckWARN(WARN_MISC))
-                   Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
-                       SVfARG(sv), hvname);
-               continue;
-           }
-           gv = gv_fetchmeth(basestash, name, len,
-                             (level >= 0) ? level + 1 : level - 1);
-           if (gv)
-               goto gotcha;
-       }
+    else {
+        linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
     }
 
-    /* if at top level, try UNIVERSAL */
+    linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
+    items = AvFILLp(linear_av); /* no +1, to skip over self */
+    while (items--) {
+        linear_sv = *linear_svp++;
+        assert(linear_sv);
+        cstash = gv_stashsv(linear_sv, 0);
+
+        /* mg.c:Perl_magic_setisa sets the fake flag on packages it had
+           to create that the user did not.  The "package" statement
+           clears it.  We also check if there's anything in the symbol
+           table at all, which would indicate a previously "fake" package
+           where someone adding things via $Foo::Bar = 1 without ever
+           using a "package" statement.
+           This was all neccesary because magic_setisa needs a place to
+           keep isarev information on packages that aren't yet defined,
+           yet we still need to issue this warning when appropriate.
+        */
+        if (!cstash || (HvMROMETA(cstash)->fake && !HvFILL(cstash))) {
+            if (ckWARN(WARN_MISC))
+                Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
+                    SVfARG(linear_sv), hvname);
+            continue;
+        }
+
+        assert(cstash);
+
+        gvp = (GV**)hv_fetch(cstash, name, len, 0);
+        if (!gvp) continue;
+        candidate = *gvp;
+        assert(candidate);
+        if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
+        if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
+            /*
+             * Found real method, cache method in topgv if:
+             *  1. topgv has no synonyms (else inheritance crosses wires)
+             *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
+             */
+            if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
+                  if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
+                  SvREFCNT_inc_simple_void_NN(cand_cv);
+                  GvCV(topgv) = cand_cv;
+                  GvCVGEN(topgv) = topgen_cmp;
+            }
+           return candidate;
+        }
+    }
 
-    if (level == 0 || level == -1) {
-       lastchance = gv_stashpvs("UNIVERSAL", 0);
+    /* Check UNIVERSAL without caching */
+    if(level == 0 || level == -1) {
+        candidate = gv_fetchmeth(NULL, name, len, 1);
+        if(candidate) {
+            cand_cv = GvCV(candidate);
+            if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
+                  if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
+                  SvREFCNT_inc_simple_void_NN(cand_cv);
+                  GvCV(topgv) = cand_cv;
+                  GvCVGEN(topgv) = topgen_cmp;
+            }
+            return candidate;
+        }
+    }
 
-       if (lastchance) {
-           if ((gv = gv_fetchmeth(lastchance, name, len,
-                                 (level >= 0) ? level + 1 : level - 1)))
-           {
-         gotcha:
-               /*
-                * Cache method in topgv if:
-                *  1. topgv has no synonyms (else inheritance crosses wires)
-                *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
-                */
-               if (topgv &&
-                   GvREFCNT(topgv) == 1 &&
-                   (cv = GvCV(gv)) &&
-                   (CvROOT(cv) || CvXSUB(cv)))
-               {
-                   if ((cv = GvCV(topgv)))
-                       SvREFCNT_dec(cv);
-                   GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
-                   GvCVGEN(topgv) = PL_sub_generation;
-               }
-               return gv;
-           }
-           else if (topgv && GvREFCNT(topgv) == 1) {
-               /* cache the fact that the method is not defined */
-               GvCVGEN(topgv) = PL_sub_generation;
-           }
-       }
+    if (topgv && GvREFCNT(topgv) == 1) {
+        /* cache the fact that the method is not defined */
+        GvCVGEN(topgv) = topgen_cmp;
     }
 
     return 0;
@@ -1423,15 +1438,22 @@ Perl_gp_ref(pTHX_ GP *gp)
     gp->gp_refcnt++;
     if (gp->gp_cv) {
        if (gp->gp_cvgen) {
-           /* multi-named GPs cannot be used for method cache */
+           /* If the GP they asked for a reference to contains
+               a method cache entry, clear it first, so that we
+               don't infect them with our cached entry */
            SvREFCNT_dec(gp->gp_cv);
            gp->gp_cv = NULL;
            gp->gp_cvgen = 0;
        }
-       else {
-           /* Adding a new name to a subroutine invalidates method cache */
-           PL_sub_generation++;
-       }
+        /* XXX if anyone finds a method cache regression with
+           the "mro" stuff, turning this else block back on
+           is probably the first place to look --blblack
+        */
+        /*
+        else {
+            PL_sub_generation++;
+        }
+        */
     }
     return gp;
 }
@@ -1510,11 +1532,13 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   dVAR;
   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
   AMT amt;
+  U32 newgen;
 
+  newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
   if (mg) {
       const AMT * const amtp = (AMT*)mg->mg_ptr;
       if (amtp->was_ok_am == PL_amagic_generation
-         && amtp->was_ok_sub == PL_sub_generation) {
+         && amtp->was_ok_sub == newgen) {
          return (bool)AMT_OVERLOADED(amtp);
       }
       sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
@@ -1524,7 +1548,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 
   Zero(&amt,1,AMT);
   amt.was_ok_am = PL_amagic_generation;
-  amt.was_ok_sub = PL_sub_generation;
+  amt.was_ok_sub = newgen;
   amt.fallback = AMGfallNO;
   amt.flags = 0;
 
@@ -1636,9 +1660,13 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
     dVAR;
     MAGIC *mg;
     AMT *amtp;
+    U32 newgen;
 
     if (!stash || !HvNAME_get(stash))
         return NULL;
+
+    newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
+
     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
     if (!mg) {
       do_update:
@@ -1648,7 +1676,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
     assert(mg);
     amtp = (AMT*)mg->mg_ptr;
     if ( amtp->was_ok_am != PL_amagic_generation
-        || amtp->was_ok_sub != PL_sub_generation )
+        || amtp->was_ok_sub != newgen )
        goto do_update;
     if (AMT_AMAGIC(amtp)) {
        CV * const ret = amtp->table[id];
diff --git a/hv.c b/hv.c
index 4266e8b..79702fd 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1531,7 +1531,7 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
        return;
     val = HeVAL(entry);
     if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
-       PL_sub_generation++;    /* may be deletion of method from stash */
+        mro_method_changed_in(hv);     /* deletion of method from stash */
     SvREFCNT_dec(val);
     if (HeKLEN(entry) == HEf_SVKEY) {
        SvREFCNT_dec(HeKEY_sv(entry));
@@ -1726,6 +1726,7 @@ S_hfreeentries(pTHX_ HV *hv)
 
        if (SvOOK(hv)) {
            HE *entry;
+            struct mro_meta *meta;
            struct xpvhv_aux *iter = HvAUX(hv);
            /* If there are weak references to this HV, we need to avoid
               freeing them up here.  In particular we need to keep the AV
@@ -1757,6 +1758,15 @@ S_hfreeentries(pTHX_ HV *hv)
            iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
            iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
 
+            if((meta = iter->xhv_mro_meta)) {
+                if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
+                if(meta->mro_linear_c3)  SvREFCNT_dec(meta->mro_linear_c3);
+                if(meta->mro_isarev)     SvREFCNT_dec(meta->mro_isarev);
+                if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
+                Safefree(meta);
+                iter->xhv_mro_meta = NULL;
+            }
+
            /* There are now no allocated pointers in the aux structure.  */
 
            SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
@@ -1878,6 +1888,7 @@ S_hv_auxinit(HV *hv) {
     iter->xhv_eiter = NULL;    /* HvEITER(hv) = NULL */
     iter->xhv_name = 0;
     iter->xhv_backreferences = 0;
+    iter->xhv_mro_meta = NULL;
     return iter;
 }
 
diff --git a/hv.h b/hv.h
index 0f60be3..7fb9fc4 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -38,12 +38,38 @@ struct shared_he {
 
 /* Subject to change.
    Don't access this directly.
+   Use the funcs in mro.c
 */
+
+typedef enum {
+    MRO_DFS, /* 0 */
+    MRO_C3   /* 1 */
+} mro_alg;
+
+struct mro_meta {
+    AV          *mro_linear_dfs; /* cached dfs @ISA linearization */
+    AV          *mro_linear_c3; /* cached c3 @ISA linearization */
+    HV         *mro_isarev;    /* reverse @ISA dependencies (who depends on us?) */
+    HV         *mro_nextmethod; /* next::method caching */
+    mro_alg     mro_which;      /* which mro alg is in use? */
+    U32         sub_generation; /* Like PL_sub_generation, but stash-local */
+    I32         is_universal;   /* We are UNIVERSAL or a potentially indirect
+                                   member of @UNIVERSAL::ISA */
+    I32         fake;           /* setisa made this fake package,
+                                   gv_fetchmeth pays attention to this,
+                                   and "package" sets it back to zero */
+};
+
+/* Subject to change.
+   Don't access this directly.
+*/
+
 struct xpvhv_aux {
     HEK                *xhv_name;      /* name, if a symbol table */
     AV         *xhv_backreferences; /* back references for weak references */
     HE         *xhv_eiter;     /* current entry of iterator */
     I32                xhv_riter;      /* current root of iterator */
+    struct mro_meta *xhv_mro_meta;
 };
 
 /* hash structure: */
@@ -240,6 +266,7 @@ C<SV*>.
 #define HvRITER_get(hv)        (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1)
 #define HvEITER_get(hv)        (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : 0)
 #define HvNAME(hv)     HvNAME_get(hv)
+#define HvMROMETA(hv)  (HvAUX(hv)->xhv_mro_meta ? HvAUX(hv)->xhv_mro_meta : mro_meta_init(hv))
 /* FIXME - all of these should use a UTF8 aware API, which should also involve
    getting the length. */
 /* This macro may go away without notice.  */
index f1b4d73..05692d5 100644 (file)
@@ -5,7 +5,7 @@ use 5.006_00;
 use warnings::register;
 
 our($VERSION, %declared);
-$VERSION = '1.09';
+$VERSION = '1.10';
 
 #=======================================================================
 
@@ -109,7 +109,7 @@ sub import {
                    # constants from cv_const_sv are read only. So we have to:
                    Internals::SvREADONLY($scalar, 1);
                    $symtab->{$name} = \$scalar;
-                   &Internals::inc_sub_generation;
+                   mro::method_changed_in($pkg);
                } else {
                    *$full_name = sub () { $scalar };
                }
diff --git a/lib/mro.pm b/lib/mro.pm
new file mode 100644 (file)
index 0000000..115110c
--- /dev/null
@@ -0,0 +1,315 @@
+#      mro.pm
+#
+#      Copyright (c) 2007 Brandon L Black
+#
+#      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 possible CPAN mro dist
+#  (for partial back-compat to 5.[68].x)
+our $VERSION = '1.00';
+
+sub import {
+    mro::set_mro(scalar(caller), $_[1]) if $_[1];
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+mro - Method Resolution Order
+
+=head1 SYNOPSIS
+
+  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.
+
+=head1 OVERVIEW
+
+One can change the mro of a given class by either C<use mro>
+as shown in the synopsis, or by using the L</mro::set_mro>
+function below.  The functions below do not require that one
+loads the "mro" module, they are provided by the core.  The
+C<use mro> syntax is just syntax sugar for setting the current
+package's mro.
+
+=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 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
+inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
+and then later adopted as the prefered 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 it's subclasses. Take the classic diamond inheritence pattern for instance:
+
+     <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 MRO (D, B, C, A), which does not have this same issue.
+
+This example is fairly trival, for more complex examples and a deeper explaination, see the links in the L<SEE ALSO - C3 Links> section.
+
+=head1 Functions
+
+=head2 mro::get_linear_isa
+
+Arguments: classname[, type]
+
+Return 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>).
+
+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
+
+Arguments: classname, type
+
+Sets the MRO of the given class to the C<type> argument (either
+C<c3> or C<dfs>).
+
+=head2 mro::get_mro
+
+Arguments: classname
+
+Returns the MRO of the given class (either C<c3> or C<dfs>)
+
+=head2 mro::get_isarev
+
+Arguments: classname
+
+Gets the C<mro_isarev> for this class, returned as an
+array of classnames.  These are every class that "isa"
+the given classname, 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
+
+Arguments: 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::get_global_sub_generation
+
+Arguments: none
+
+Returns the current value of C<PL_sub_generation>.
+
+=head2 mro::invalidate_all_method_caches
+
+Arguments: none
+
+Increments C<PL_sub_generation>, which invalidates method
+caching in all packages.
+
+=head2 mro::get_sub_generation
+
+Arguments: classname
+
+Returns the current value of a given package's C<sub_generation>.
+This is only incremented when necessary for that package.
+
+If one is trying to determine whether significant (method/cache-
+affecting) changes have occured for a given stash since you last
+checked, you should check both this and the global one above.
+
+=head2 mro::method_changed_in
+
+Arguments: classname
+
+Invalidates the method cache of any classes dependant on the
+given class.
+
+=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:
+
+1) First, it determines the linearized C3 MRO of
+the object or class it is being called on.
+
+2) Then, it determines the class and method name
+of the context it was invoked from.
+
+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.
+
+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).
+
+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 glob C<*Foo::foo> 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 is 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
+
+Like 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 "goto &maybe::next::method");
+
+=head1 SEE ALSO - C3 Links
+
+=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
index 1ca22b4..fdc1cfe 100644 (file)
@@ -1,6 +1,6 @@
 package overload;
 
-our $VERSION = '1.04';
+our $VERSION = '1.05';
 
 sub nil {}
 
@@ -95,12 +95,13 @@ sub AddrRef {
 
 sub mycan {                            # Real can would leave stubs.
   my ($package, $meth) = @_;
-  return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
-  my $p;
-  foreach $p (@{$package . "::ISA"}) {
-    my $out = mycan($p, $meth);
-    return $out if $out;
+
+  my $mro = mro::get_linear_isa($package);
+  foreach my $p (@$mro) {
+    my $fqmeth = $p . q{::} . $meth;
+    return \*{$fqmeth} if defined &{$fqmeth};
   }
+
   return undef;
 }
 
diff --git a/mg.c b/mg.c
index 1aaf0ac..ddaf2b3 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1530,8 +1530,18 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
     PERL_UNUSED_ARG(sv);
-    PERL_UNUSED_ARG(mg);
-    PL_sub_generation++;
+
+    /* The first case occurs via setisa,
+       the second via setisa_elem, which
+       calls this same magic */
+    mro_isa_changed_in(
+        GvSTASH(
+            SvTYPE(mg->mg_obj) == SVt_PVGV
+                ? (GV*)mg->mg_obj
+                : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
+        )
+    );
+
     return 0;
 }
 
@@ -1541,7 +1551,6 @@ Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
     dVAR;
     PERL_UNUSED_ARG(sv);
     PERL_UNUSED_ARG(mg);
-    /* HV_badAMAGIC_on(Sv_STASH(sv)); */
     PL_amagic_generation++;
 
     return 0;
diff --git a/mro.c b/mro.c
new file mode 100644 (file)
index 0000000..87b5cb2
--- /dev/null
+++ b/mro.c
@@ -0,0 +1,1002 @@
+/*    mro.c
+ *
+ *    Copyright (c) 2007 Brandon L Black
+ *
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+=head1 MRO Functions
+
+These functions are related to the method resolution order of perl classes
+
+=cut
+*/
+
+#include "EXTERN.h"
+#include "perl.h"
+
+struct mro_meta*
+Perl_mro_meta_init(pTHX_ HV* stash)
+{
+    void* newmeta;
+
+    assert(stash);
+    assert(HvAUX(stash));
+    assert(!(HvAUX(stash)->xhv_mro_meta));
+    Newxz(newmeta, sizeof(struct mro_meta), char);
+    HvAUX(stash)->xhv_mro_meta = (struct mro_meta*)newmeta;
+    ((struct mro_meta*)newmeta)->sub_generation = 1;
+
+    /* Manually flag UNIVERSAL as being universal.
+       This happens early in perl booting (when universal.c
+       does the newXS calls for UNIVERSAL::*), and infects
+       other packages as they are added to UNIVERSAL's MRO
+    */
+    if(HvNAMELEN_get(stash) == 9
+       && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) {
+            HvMROMETA(stash)->is_universal = 1;
+    }
+
+    return newmeta;
+}
+
+#if defined(USE_ITHREADS)
+
+/* for sv_dup on new threads */
+struct mro_meta*
+Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
+{
+    void* newmeta_void;
+    struct mro_meta* newmeta;
+
+    assert(smeta);
+
+    Newx(newmeta_void, sizeof(struct mro_meta), char);
+    newmeta = (struct mro_meta*)newmeta_void;
+
+    newmeta->mro_which       = smeta->mro_which;
+    newmeta->sub_generation  = smeta->sub_generation;
+    newmeta->is_universal    = smeta->is_universal;
+    newmeta->fake            = smeta->fake;
+    newmeta->mro_linear_dfs  = smeta->mro_linear_dfs
+        ? (AV*) SvREFCNT_inc(sv_dup((SV*)smeta->mro_linear_dfs, param))
+        : 0;
+    newmeta->mro_linear_c3   = smeta->mro_linear_c3
+        ? (AV*) SvREFCNT_inc(sv_dup((SV*)smeta->mro_linear_c3, param))
+        : 0;
+    newmeta->mro_isarev      = smeta->mro_isarev
+        ? (HV*) SvREFCNT_inc(sv_dup((SV*)smeta->mro_isarev, param))
+        : 0;
+    newmeta->mro_nextmethod  = smeta->mro_nextmethod
+        ? (HV*) SvREFCNT_inc(sv_dup((SV*)smeta->mro_nextmethod, param))
+        : 0;
+
+    return newmeta;
+}
+
+#endif /* USE_ITHREADS */
+
+/*
+=for apidoc mro_get_linear_isa_dfs
+
+Returns the Depth-First Search 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).
+
+=cut
+*/
+AV*
+Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
+{
+    AV* retval;
+    GV** gvp;
+    GV* gv;
+    AV* av;
+    SV** svp;
+    I32 items;
+    AV* subrv;
+    SV** subrv_p;
+    I32 subrv_items;
+    const char* stashname;
+    struct mro_meta* meta;
+
+    assert(stash);
+    assert(HvAUX(stash));
+
+    stashname = HvNAME_get(stash);
+    if (!stashname)
+      Perl_croak(aTHX_
+                 "Can't linearize anonymous symbol table");
+
+    if (level > 100)
+        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
+              stashname);
+
+    meta = HvMROMETA(stash);
+    if((retval = meta->mro_linear_dfs)) {
+        /* return cache if valid */
+        return retval;
+    }
+
+    /* not in cache, make a new one */
+    retval = newAV();
+    av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
+
+    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
+    av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
+
+    if(av) {
+        HV* stored = (HV*)sv_2mortal((SV*)newHV());
+        svp = AvARRAY(av);
+        items = AvFILLp(av) + 1;
+        while (items--) {
+            SV* const sv = *svp++;
+            HV* const basestash = gv_stashsv(sv, 0);
+
+            if (!basestash) {
+                if(!hv_exists_ent(stored, sv, 0)) {
+                    av_push(retval, newSVsv(sv));
+                    hv_store_ent(stored, sv, &PL_sv_undef, 0);
+                }
+            }
+            else {
+                subrv = mro_get_linear_isa_dfs(basestash, level + 1);
+                subrv_p = AvARRAY(subrv);
+                subrv_items = AvFILLp(subrv) + 1;
+                while(subrv_items--) {
+                    SV* subsv = *subrv_p++;
+                    if(!hv_exists_ent(stored, subsv, 0)) {
+                        av_push(retval, newSVsv(subsv));
+                        hv_store_ent(stored, subsv, &PL_sv_undef, 0);
+                    }
+                }
+            }
+        }
+    }
+
+    SvREADONLY_on(retval);
+    meta->mro_linear_dfs = retval;
+    return 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).
+
+=cut
+*/
+
+AV*
+Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
+{
+    AV* retval;
+    GV** gvp;
+    GV* gv;
+    AV* isa;
+    const char* stashname;
+    STRLEN stashname_len;
+    struct mro_meta* meta;
+
+    assert(stash);
+    assert(HvAUX(stash));
+
+    stashname = HvNAME_get(stash);
+    stashname_len = HvNAMELEN_get(stash);
+    if (!stashname)
+      Perl_croak(aTHX_
+                 "Can't linearize anonymous symbol table");
+
+    if (level > 100)
+        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
+              stashname);
+
+    meta = HvMROMETA(stash);
+    if((retval = meta->mro_linear_c3)) {
+        /* return cache if valid */
+        return retval;
+    }
+
+    /* not in cache, make a new one */
+
+    retval = newAV();
+    av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
+
+    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
+    isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
+
+    if(isa && AvFILLp(isa) >= 0) {
+        SV** seqs_ptr;
+        I32 seqs_items;
+        HV* tails = (HV*)sv_2mortal((SV*)newHV());
+        AV* seqs = (AV*)sv_2mortal((SV*)newAV());
+        I32 items = AvFILLp(isa) + 1;
+        SV** isa_ptr = AvARRAY(isa);
+        while(items--) {
+            AV* isa_lin;
+            SV* isa_item = *isa_ptr++;
+            HV* isa_item_stash = gv_stashsv(isa_item, 0);
+            if(!isa_item_stash) {
+                isa_lin = newAV();
+                av_push(isa_lin, newSVsv(isa_item));
+            }
+            else {
+                isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
+            }
+            av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
+        }
+        av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
+
+        seqs_ptr = AvARRAY(seqs);
+        seqs_items = AvFILLp(seqs) + 1;
+        while(seqs_items--) {
+            AV* seq = (AV*)*seqs_ptr++;
+            I32 seq_items = AvFILLp(seq);
+            if(seq_items > 0) {
+                SV** seq_ptr = AvARRAY(seq) + 1;
+                while(seq_items--) {
+                    SV* seqitem = *seq_ptr++;
+                    HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
+                    if(!he) {
+                        hv_store_ent(tails, seqitem, newSViv(1), 0);
+                    }
+                    else {
+                        SV* val = HeVAL(he);
+                        sv_inc(val);
+                    }
+                }
+            }
+        }
+
+        while(1) {
+            SV* seqhead = NULL;
+            SV* cand = NULL;
+            SV* winner = NULL;
+            SV* val;
+            HE* tail_entry;
+            AV* seq;
+            SV** avptr = AvARRAY(seqs);
+            items = AvFILLp(seqs)+1;
+            while(items--) {
+                SV** svp;
+                seq = (AV*)*avptr++;
+                if(AvFILLp(seq) < 0) continue;
+                svp = av_fetch(seq, 0, 0);
+                seqhead = *svp;
+                if(!winner) {
+                    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);
+                }
+                if(!sv_cmp(seqhead, winner)) {
+
+                    /* this is basically shift(@seq) in void context */
+                    SvREFCNT_dec(*AvARRAY(seq));
+                    *AvARRAY(seq) = &PL_sv_undef;
+                    AvARRAY(seq) = AvARRAY(seq) + 1;
+                    AvMAX(seq)--;
+                    AvFILLp(seq)--;
+
+                    if(AvFILLp(seq) < 0) continue;
+                    svp = av_fetch(seq, 0, 0);
+                    seqhead = *svp;
+                    tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
+                    val = HeVAL(tail_entry);
+                    sv_dec(val);
+                }
+            }
+            if(!cand) break;
+            if(!winner) {
+                SvREFCNT_dec(retval);
+                Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
+                    "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
+            }
+        }
+    }
+
+    SvREADONLY_on(retval);
+    meta->mro_linear_c3 = retval;
+    return retval;
+}
+
+/*
+=for apidoc mro_get_linear_isa
+
+Returns either C<mro_get_linear_isa_c3> or
+C<mro_get_linear_isa_dfs> for the given stash,
+dependant upon which MRO is in effect
+for that stash.  The return value is a
+read-only AV*.
+
+=cut
+*/
+AV*
+Perl_mro_get_linear_isa(pTHX_ HV *stash)
+{
+    struct mro_meta* meta;
+    assert(stash);
+    assert(HvAUX(stash));
+
+    meta = HvMROMETA(stash);
+    if(meta->mro_which == MRO_DFS) {
+        return mro_get_linear_isa_dfs(stash, 0);
+    } else if(meta->mro_which == MRO_C3) {
+        return mro_get_linear_isa_c3(stash, 0);
+    } else {
+        Perl_croak(aTHX_ "Internal error: invalid MRO!");
+    }
+}
+
+/*
+=for apidoc mro_isa_changed_in
+
+Takes the neccesary steps (cache invalidations, mostly)
+when the @ISA of the given package has changed.  Invoked
+by the C<setisa> magic, should not need to invoke directly.
+
+=cut
+*/
+void
+Perl_mro_isa_changed_in(pTHX_ HV* stash)
+{
+    dVAR;
+    HV* isarev;
+    AV* linear_mro;
+    HE* iter;
+    SV** svp;
+    I32 items;
+    struct mro_meta* meta;
+    char* stashname;
+
+    stashname = HvNAME_get(stash);
+
+    /* wipe out the cached linearizations for this stash */
+    meta = HvMROMETA(stash);
+    SvREFCNT_dec((SV*)meta->mro_linear_dfs);
+    SvREFCNT_dec((SV*)meta->mro_linear_c3);
+    meta->mro_linear_dfs = NULL;
+    meta->mro_linear_c3 = NULL;
+
+    /* Wipe the global method cache if this package
+       is UNIVERSAL or one of its parents */
+    if(meta->is_universal)
+        PL_sub_generation++;
+
+    /* Wipe the local method cache otherwise */
+    else
+        meta->sub_generation++;
+
+    /* wipe next::method cache too */
+    if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
+    
+    /* Iterate the isarev (classes that are our children),
+       wiping out their linearization and method caches */
+    if((isarev = meta->mro_isarev)) {
+        hv_iterinit(isarev);
+        while((iter = hv_iternext(isarev))) {
+            SV* revkey = hv_iterkeysv(iter);
+            HV* revstash = gv_stashsv(revkey, 0);
+            struct mro_meta* revmeta = HvMROMETA(revstash);
+            SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
+            SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
+            revmeta->mro_linear_dfs = NULL;
+            revmeta->mro_linear_c3 = NULL;
+            if(!meta->is_universal)
+                revmeta->sub_generation++;
+            if(revmeta->mro_nextmethod)
+                hv_clear(revmeta->mro_nextmethod);
+        }
+    }
+
+    /* we're starting at the 2nd element, skipping ourselves here */
+    linear_mro = mro_get_linear_isa(stash);
+    svp = AvARRAY(linear_mro) + 1;
+    items = AvFILLp(linear_mro);
+    while (items--) {
+        SV* const sv = *svp++;
+        struct mro_meta* mrometa;
+        HV* mroisarev;
+
+        HV* mrostash = gv_stashsv(sv, 0);
+        if(!mrostash) {
+            mrostash = gv_stashsv(sv, GV_ADD);
+            /*
+               We created the package on the fly, so
+               that we could store isarev information.
+               This flag lets gv_fetchmeth know about it,
+               so that it can still generate the very useful
+               "Can't locate package Foo for @Bar::ISA" warning.
+            */
+            HvMROMETA(mrostash)->fake = 1;
+        }
+
+        mrometa = HvMROMETA(mrostash);
+        mroisarev = mrometa->mro_isarev;
+
+        /* is_universal is viral */
+        if(meta->is_universal)
+            mrometa->is_universal = 1;
+
+        if(!mroisarev)
+            mroisarev = mrometa->mro_isarev = newHV();
+
+        if(!hv_exists(mroisarev, stashname, strlen(stashname)))
+            hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
+
+        if(isarev) {
+            hv_iterinit(isarev);
+            while((iter = hv_iternext(isarev))) {
+                SV* revkey = hv_iterkeysv(iter);
+                if(!hv_exists_ent(mroisarev, revkey, 0))
+                    hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
+            }
+        }
+    }
+}
+
+/*
+=for apidoc mro_method_changed_in
+
+Like C<mro_isa_changed_in>, but invalidates method
+caching on any child classes of the given stash, so
+that they might notice the changes in this one.
+
+Ideally, all instances of C<PL_sub_generation++> in
+the perl source should be replaced by calls to this.
+Some already are, but some are more difficult to
+replace.
+
+Perl has always had problems with method caches
+getting out of sync when one directly manipulates
+stashes via things like C<%{Foo::} = %{Bar::}> or 
+C<${Foo::}{bar} = ...> or the equivalent.  If
+you do this in core or XS code, call this afterwards
+on the destination stash to get things back in sync.
+
+If you're doing such a thing from pure perl, use
+C<mro::method_changed_in(classname)>, which
+just calls this.
+
+=cut
+*/
+void
+Perl_mro_method_changed_in(pTHX_ HV *stash)
+{
+    struct mro_meta* meta = HvMROMETA(stash);
+    HV* isarev;
+    HE* iter;
+
+    /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
+       invalidate all method caches globally */
+    if(meta->is_universal) {
+        PL_sub_generation++;
+        return;
+    }
+
+    /* else, invalidate the method caches of all child classes,
+       but not itself */
+    if((isarev = meta->mro_isarev)) {
+        hv_iterinit(isarev);
+        while((iter = hv_iternext(isarev))) {
+            SV* revkey = hv_iterkeysv(iter);
+            HV* revstash = gv_stashsv(revkey, 0);
+            struct mro_meta* mrometa = HvMROMETA(revstash);
+            mrometa->sub_generation++;
+            if(mrometa->mro_nextmethod)
+                hv_clear(mrometa->mro_nextmethod);
+        }
+    }
+}
+
+/* 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;
+}
+
+STATIC SV*
+__nextcan(pTHX_ SV* self, I32 throw_nomethod)
+{
+    register I32 cxix;
+    register const PERL_CONTEXT *ccstack = cxstack;
+    const PERL_SI *top_si = PL_curstackinfo;
+    HV* selfstash;
+    GV* cvgv;
+    SV *stashname;
+    const char *fq_subname;
+    const char *subname;
+    STRLEN fq_subname_len;
+    STRLEN stashname_len;
+    STRLEN subname_len;
+    SV* sv;
+    GV** gvp;
+    AV* linear_av;
+    SV** linear_svp;
+    SV* linear_sv;
+    HV* curstash;
+    GV* candidate = NULL;
+    CV* cand_cv = NULL;
+    const char *hvname;
+    I32 items;
+    struct mro_meta* selfmeta;
+    HV* nmcache;
+    HE* cache_entry;
+
+    if(sv_isobject(self))
+        selfstash = SvSTASH(SvRV(self));
+    else
+        selfstash = gv_stashsv(self, 0);
+
+    assert(selfstash);
+
+    hvname = HvNAME_get(selfstash);
+    if (!hvname)
+        Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
+
+    cxix = __dopoptosub_at(cxstack, cxstack_ix);
+
+    /* 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 */
+    for (;;) {
+        /* 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;
+    }
+
+    /* If we made it to here, we found our context */
+
+    selfmeta = HvMROMETA(selfstash);
+    if(!(nmcache = selfmeta->mro_nextmethod)) {
+        nmcache = selfmeta->mro_nextmethod = newHV();
+    }
+
+    if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
+        SV* val = HeVAL(cache_entry);
+        if(val == &PL_sv_undef) {
+            if(throw_nomethod)
+                Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
+        }
+        return val;
+    }
+
+    /* beyond here is just for cache misses, so perf isn't as critical */
+
+    stashname_len = subname - fq_subname - 2;
+    stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
+
+    linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
+
+    linear_svp = AvARRAY(linear_av);
+    items = AvFILLp(linear_av) + 1;
+
+    while (items--) {
+        linear_sv = *linear_svp++;
+        assert(linear_sv);
+        if(sv_eq(linear_sv, stashname))
+            break;
+    }
+
+    if(items > 0) {
+        while (items--) {
+            linear_sv = *linear_svp++;
+            assert(linear_sv);
+            curstash = gv_stashsv(linear_sv, FALSE);
+
+            if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
+                if (ckWARN(WARN_MISC))
+                    Perl_warner(aTHX_ packWARN(WARN_MISC), "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);
+            if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
+                SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
+                hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
+                return (SV*)cand_cv;
+            }
+        }
+    }
+
+    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);
+    return &PL_sv_undef;
+}
+
+#include "XSUB.h"
+
+XS(XS_mro_get_linear_isa);
+XS(XS_mro_set_mro);
+XS(XS_mro_get_mro);
+XS(XS_mro_get_isarev);
+XS(XS_mro_is_universal);
+XS(XS_mro_get_global_sub_generation);
+XS(XS_mro_invalidate_all_method_caches);
+XS(XS_mro_get_sub_generation);
+XS(XS_mro_method_changed_in);
+XS(XS_next_can);
+XS(XS_next_method);
+XS(XS_maybe_next_method);
+
+void
+Perl_boot_core_mro(pTHX)
+{
+    dVAR;
+    static const char file[] = __FILE__;
+
+    newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
+    newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
+    newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
+    newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
+    newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
+    newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_generation, file, "");
+    newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_all_method_caches, file, "");
+    newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
+    newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
+    newXS("next::can", XS_next_can, file);
+    newXS("next::method", XS_next_method, file);
+    newXS("maybe::next::method", XS_maybe_next_method, file);
+}
+
+XS(XS_mro_get_linear_isa) {
+    dVAR;
+    dXSARGS;
+    AV* RETVAL;
+    HV* class_stash;
+    SV* classname;
+
+    PERL_UNUSED_ARG(cv);
+
+    if(items < 1 || items > 2)
+       Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
+
+    classname = ST(0);
+    class_stash = gv_stashsv(classname, 0);
+    if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+    if(items > 1) {
+        char* which = SvPV_nolen(ST(1));
+        if(strEQ(which, "dfs"))
+            RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
+        else if(strEQ(which, "c3"))
+            RETVAL = mro_get_linear_isa_c3(class_stash, 0);
+        else
+            Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
+    }
+    else {
+        RETVAL = mro_get_linear_isa(class_stash);
+    }
+
+    ST(0) = newRV_inc((SV*)RETVAL);
+    sv_2mortal(ST(0));
+    XSRETURN(1);
+}
+
+XS(XS_mro_set_mro)
+{
+    dVAR;
+    dXSARGS;
+    SV* classname;
+    char* whichstr;
+    mro_alg which;
+    HV* class_stash;
+    struct mro_meta* meta;
+
+    PERL_UNUSED_ARG(cv);
+
+    if (items != 2)
+       Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
+
+    classname = ST(0);
+    whichstr = SvPV_nolen(ST(1));
+    class_stash = gv_stashsv(classname, GV_ADD);
+    if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
+    meta = HvMROMETA(class_stash);
+
+    if(strEQ(whichstr, "dfs"))
+        which = MRO_DFS;
+    else if(strEQ(whichstr, "c3"))
+        which = MRO_C3;
+    else
+        Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
+
+    if(meta->mro_which != which) {
+        meta->mro_which = which;
+        /* Only affects local method cache, not
+           even child classes */
+        meta->sub_generation++;
+        if(meta->mro_nextmethod)
+            hv_clear(meta->mro_nextmethod);
+    }
+
+    XSRETURN_EMPTY;
+}
+
+
+XS(XS_mro_get_mro)
+{
+    dVAR;
+    dXSARGS;
+    SV* classname;
+    HV* class_stash;
+    struct mro_meta* meta;
+
+    PERL_UNUSED_ARG(cv);
+
+    if (items != 1)
+       Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
+
+    classname = ST(0);
+    class_stash = gv_stashsv(classname, 0);
+    if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+    meta = HvMROMETA(class_stash);
+
+    if(meta->mro_which == MRO_DFS)
+        ST(0) = sv_2mortal(newSVpvn("dfs", 3));
+    else
+        ST(0) = sv_2mortal(newSVpvn("c3", 2));
+
+    XSRETURN(1);
+}
+
+XS(XS_mro_get_isarev)
+{
+    dVAR;
+    dXSARGS;
+    SV* classname;
+    HV* class_stash;
+    HV* isarev;
+
+    PERL_UNUSED_ARG(cv);
+
+    if (items != 1)
+       Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
+
+    classname = ST(0);
+
+    class_stash = gv_stashsv(classname, 0);
+    if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+    SP -= items;
+   
+    if((isarev = HvMROMETA(class_stash)->mro_isarev)) {
+        HE* iter;
+        hv_iterinit(isarev);
+        while((iter = hv_iternext(isarev)))
+            XPUSHs(hv_iterkeysv(iter));
+    }
+
+    PUTBACK;
+    return;
+}
+
+XS(XS_mro_is_universal)
+{
+    dVAR;
+    dXSARGS;
+    SV* classname;
+    HV* class_stash;
+
+    PERL_UNUSED_ARG(cv);
+
+    if (items != 1)
+       Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
+
+    classname = ST(0);
+    class_stash = gv_stashsv(classname, 0);
+    if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+    HvMROMETA(class_stash)->is_universal
+        ? XSRETURN_YES
+        : XSRETURN_NO;
+}
+
+XS(XS_mro_get_global_sub_generation)
+{
+    dVAR;
+    dXSARGS;
+
+    PERL_UNUSED_ARG(cv);
+
+    if (items != 0)
+        Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
+
+    ST(0) = sv_2mortal(newSViv(PL_sub_generation));
+    XSRETURN(1);
+}
+
+XS(XS_mro_invalidate_all_method_caches)
+{
+    dVAR;
+    dXSARGS;
+
+    PERL_UNUSED_ARG(cv);
+
+    if (items != 0)
+        Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
+
+    PL_sub_generation++;
+
+    XSRETURN_EMPTY;
+}
+
+XS(XS_mro_get_sub_generation)
+{
+    dVAR;
+    dXSARGS;
+    SV* classname;
+    HV* class_stash;
+
+    PERL_UNUSED_ARG(cv);
+
+    if(items != 1)
+        Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
+
+    classname = ST(0);
+    class_stash = gv_stashsv(classname, 0);
+    if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+    ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
+    XSRETURN(1);
+}
+
+XS(XS_mro_method_changed_in)
+{
+    dVAR;
+    dXSARGS;
+    SV* classname;
+    HV* class_stash;
+
+    PERL_UNUSED_ARG(cv);
+
+    if(items != 1)
+        Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
+    
+    classname = ST(0);
+
+    class_stash = gv_stashsv(classname, 0);
+    if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+    mro_method_changed_in(class_stash);
+
+    XSRETURN_EMPTY;
+}
+
+XS(XS_next_can)
+{
+    dVAR;
+    dXSARGS;
+    SV* self = ST(0);
+    SV* methcv = __nextcan(aTHX_ self, 0);
+
+    PERL_UNUSED_ARG(cv);
+    PERL_UNUSED_VAR(items);
+
+    if(methcv == &PL_sv_undef) {
+        ST(0) = &PL_sv_undef;
+    }
+    else {
+        ST(0) = sv_2mortal(newRV_inc(methcv));
+    }
+
+    XSRETURN(1);
+}
+
+XS(XS_next_method)
+{
+    dMARK;
+    dAX;
+    SV* self = ST(0);
+    SV* methcv = __nextcan(aTHX_ self, 1);
+
+    PERL_UNUSED_ARG(cv);
+
+    PL_markstack_ptr++;
+    call_sv(methcv, GIMME_V);
+}
+
+XS(XS_maybe_next_method)
+{
+    dMARK;
+    dAX;
+    SV* self = ST(0);
+    SV* methcv = __nextcan(aTHX_ self, 0);
+
+    PERL_UNUSED_ARG(cv);
+
+    if(methcv == &PL_sv_undef) {
+        ST(0) = &PL_sv_undef;
+        XSRETURN(1);
+    }
+
+    PL_markstack_ptr++;
+    call_sv(methcv, GIMME_V);
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/op.c b/op.c
index 5436a71..55f0571 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3649,6 +3649,11 @@ Perl_package(pTHX_ OP *o)
     save_item(PL_curstname);
 
     PL_curstash = gv_stashsv(sv, GV_ADD);
+
+    /* In case mg.c:Perl_magic_setisa faked
+       this package earlier, we clear the fake flag */
+    HvMROMETA(PL_curstash)->fake = 0;
+
     sv_setsv(PL_curstname, sv);
 
     PL_hints |= HINT_BLOCK_SCOPE;
@@ -5291,9 +5296,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            sv_setpvn((SV*)gv, ps, ps_len);
        else
            sv_setiv((SV*)gv, -1);
+
        SvREFCNT_dec(PL_compcv);
        cv = PL_compcv = NULL;
-       PL_sub_generation++;
        goto done;
     }
 
@@ -5387,7 +5392,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            GvCV(gv) = NULL;
            cv = newCONSTSUB(NULL, name, const_sv);
        }
-       PL_sub_generation++;
+        mro_method_changed_in( /* sub Foo::Bar () { 123 } */
+            (CvGV(cv) && GvSTASH(CvGV(cv)))
+                ? GvSTASH(CvGV(cv))
+                : CvSTASH(cv)
+                    ? CvSTASH(cv)
+                    : PL_curstash
+        );
        if (PL_madskills)
            goto install_block;
        op_free(block);
@@ -5470,7 +5481,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                }
            }
            GvCVGEN(gv) = 0;
-           PL_sub_generation++;
+            mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
        }
     }
     CvGV(cv) = gv;
@@ -5802,7 +5813,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
        if (name) {
            GvCV(gv) = cv;
            GvCVGEN(gv) = 0;
-           PL_sub_generation++;
+            mro_method_changed_in(GvSTASH(gv)); /* newXS */
        }
     }
     CvGV(cv) = gv;
diff --git a/perl.c b/perl.c
index c3f9e88..8e8c325 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2163,6 +2163,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     boot_core_PerlIO();
     boot_core_UNIVERSAL();
     boot_core_xsutils();
+    boot_core_mro();
 
     if (xsinit)
        (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
index 7f82d8b..a36ab88 100644 (file)
@@ -1326,7 +1326,7 @@ accessible via @ISA and UNIVERSAL::.
 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 side-effect creates a glob with the given C<name> in the given C<stash>
 which in the case of success contains an alias for the subroutine, and sets
-up caching info for this glob.  Similarly for all the searched stashes.
+up caching info for this glob.
 
 This function grants C<"SUPER"> token as a postfix of the stash name. The
 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
index 76a55cb..71bbb5c 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -192,7 +192,7 @@ PP(pp_sassign)
 
        if (strEQ(GvNAME(right),"isa")) {
            GvCVGEN(right) = 0;
-           ++PL_sub_generation;
+           ++PL_sub_generation; /* I don't get this at all --blblack */
        }
     }
     SvSetMagicSV(right, left);
@@ -3060,7 +3060,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
        if (he) {
            gv = (GV*)HeVAL(he);
            if (isGV(gv) && GvCV(gv) &&
-               (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
+               (!GvCVGEN(gv) || GvCVGEN(gv)
+                  == (PL_sub_generation + HvMROMETA(stash)->sub_generation)))
                return (SV*)GvCV(gv);
        }
     }
diff --git a/proto.h b/proto.h
index 52dd8e7..a582063 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -635,6 +635,31 @@ PERL_CALLCONV GV*  Perl_gv_fetchfile(pTHX_ const char* name)
 PERL_CALLCONV GV*      Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN len, const U32 flags)
                        __attribute__nonnull__(pTHX_1);
 
+PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
+                       __attribute__nonnull__(pTHX_1);
+
+#if defined(USE_ITHREADS)
+PERL_CALLCONV struct mro_meta* Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+
+#endif
+PERL_CALLCONV AV*      Perl_mro_get_linear_isa(pTHX_ HV* stash)
+                       __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV AV*      Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
+                       __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV AV*      Perl_mro_get_linear_isa_dfs(pTHX_ HV* stash, I32 level)
+                       __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV void     Perl_mro_isa_changed_in(pTHX_ HV* stash)
+                       __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV void     Perl_mro_method_changed_in(pTHX_ HV* stash)
+                       __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV void     Perl_boot_core_mro(pTHX);
 PERL_CALLCONV GV*      Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
                        __attribute__nonnull__(pTHX_2);
 
diff --git a/scope.c b/scope.c
index d52d12d..171fd78 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -256,7 +256,7 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty)
        GP *gp = Perl_newGP(aTHX_ gv);
 
        if (GvCVu(gv))
-           PL_sub_generation++;        /* taking a method out of circulation */
+            mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/
        if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
            gp->gp_io = newIO();
            IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
@@ -740,7 +740,7 @@ Perl_leave_scope(pTHX_ I32 base)
            gp_free(gv);
            GvGP(gv) = (GP*)ptr;
            if (GvCVu(gv))
-               PL_sub_generation++;  /* putting a method back into circulation */
+                mro_method_changed_in(GvSTASH(gv)); /* putting a method back into circulation ("local")*/
            SvREFCNT_dec(gv);
            break;
        case SAVEt_FREESV:
diff --git a/sv.c b/sv.c
index ecea4f9..917f806 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3241,7 +3241,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
                    SvREFCNT_dec(GvCV(dstr));
                    GvCV(dstr) = NULL;
                    GvCVGEN(dstr) = 0; /* Switch off cacheness. */
-                   PL_sub_generation++;
+                   mro_method_changed_in(GvSTASH(dstr));
                }
            }
            SAVEGENERICSV(*location);
@@ -3287,7 +3287,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
            }
            GvCVGEN(dstr) = 0; /* Switch off cacheness. */
            GvASSUMECV_on(dstr);
-           PL_sub_generation++;
+           mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
        }
        *location = sref;
        if (import_flag && !(GvFLAGS(dstr) & import_flag)
@@ -10157,6 +10157,11 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
                                ? (AV*) SvREFCNT_inc(
                                        sv_dup((SV*)saux->xhv_backreferences, param))
                                : 0;
+
+                        daux->xhv_mro_meta = saux->xhv_mro_meta
+                            ? mro_meta_dup(saux->xhv_mro_meta, param)
+                            : 0;
+
                        /* Record stashes for possible cloning in Perl_clone(). */
                        if (hvname)
                            av_push(param->stashes, dstr);
diff --git a/t/TEST b/t/TEST
index f37d2be..cfc0725 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -104,7 +104,7 @@ sub _populate_hash {
 }
 
 unless (@ARGV) {
-    foreach my $dir (qw(base comp cmd run io op uni)) {
+    foreach my $dir (qw(base comp cmd run io op uni mro)) {
        _find_tests($dir);
     }
     _find_tests("lib") unless $::core;
diff --git a/t/mro/basic.t b/t/mro/basic.t
new file mode 100644 (file)
index 0000000..303708e
--- /dev/null
@@ -0,0 +1,53 @@
+#!./perl
+
+use strict;
+use warnings;
+
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More;
+
+plan tests => 8;
+
+{
+    package MRO_A;
+    our @ISA = qw//;
+    package MRO_B;
+    our @ISA = qw//;
+    package MRO_C;
+    our @ISA = qw//;
+    package MRO_D;
+    our @ISA = qw/MRO_A MRO_B MRO_C/;
+    package MRO_E;
+    our @ISA = qw/MRO_A MRO_B MRO_C/;
+    package MRO_F;
+    our @ISA = qw/MRO_D MRO_E/;
+}
+
+is(mro::get_mro('MRO_F'), 'dfs');
+is_deeply(mro::get_linear_isa('MRO_F'),
+    [qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/]
+);
+mro::set_mro('MRO_F', 'c3');
+is(mro::get_mro('MRO_F'), 'c3');
+is_deeply(mro::get_linear_isa('MRO_F'),
+    [qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/]
+);
+
+my @isarev = sort { $a cmp $b } mro::get_isarev('MRO_B');
+is_deeply(\@isarev,
+    [qw/MRO_D MRO_E MRO_F/]
+);
+
+ok(!mro::is_universal('MRO_B'));
+
+@UNIVERSAL::ISA = qw/MRO_F/;
+ok(mro::is_universal('MRO_B'));
+
+@UNIVERSAL::ISA = ();
+ok(mro::is_universal('MRO_B'));
diff --git a/t/mro/basic_01_c3.t b/t/mro/basic_01_c3.t
new file mode 100644 (file)
index 0000000..95d3479
--- /dev/null
@@ -0,0 +1,53 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 4;
+
+=pod
+
+This tests the classic diamond inheritence pattern.
+
+   <A>
+  /   \
+<B>   <C>
+  \   /
+   <D>
+
+=cut
+
+{
+    package Diamond_A;
+    sub hello { 'Diamond_A::hello' }
+}
+{
+    package Diamond_B;
+    use base 'Diamond_A';
+}
+{
+    package Diamond_C;
+    use base 'Diamond_A';     
+    
+    sub hello { 'Diamond_C::hello' }
+}
+{
+    package Diamond_D;
+    use base ('Diamond_B', 'Diamond_C');
+    use mro 'c3';
+}
+
+is_deeply(
+    mro::get_linear_isa('Diamond_D'),
+    [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+    '... got the right MRO for Diamond_D');
+
+is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected');
+is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
+is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
diff --git a/t/mro/basic_01_dfs.t b/t/mro/basic_01_dfs.t
new file mode 100644 (file)
index 0000000..11c15a2
--- /dev/null
@@ -0,0 +1,53 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 4;
+
+=pod
+
+This tests the classic diamond inheritence pattern.
+
+   <A>
+  /   \
+<B>   <C>
+  \   /
+   <D>
+
+=cut
+
+{
+    package Diamond_A;
+    sub hello { 'Diamond_A::hello' }
+}
+{
+    package Diamond_B;
+    use base 'Diamond_A';
+}
+{
+    package Diamond_C;
+    use base 'Diamond_A';     
+    
+    sub hello { 'Diamond_C::hello' }
+}
+{
+    package Diamond_D;
+    use base ('Diamond_B', 'Diamond_C');
+    use mro 'dfs';
+}
+
+is_deeply(
+    mro::get_linear_isa('Diamond_D'),
+    [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ],
+    '... got the right MRO for Diamond_D');
+
+is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected');
+is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
+is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
diff --git a/t/mro/basic_02_c3.t b/t/mro/basic_02_c3.t
new file mode 100644 (file)
index 0000000..86fbc32
--- /dev/null
@@ -0,0 +1,121 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 10;
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My first example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(D,E): pass
+class A(B,C): pass
+
+
+                          6
+                         ---
+Level 3                 | O |                  (more general)
+                      /  ---  \
+                     /    |    \                      |
+                    /     |     \                     |
+                   /      |      \                    |
+                  ---    ---    ---                   |
+Level 2        3 | D | 4| E |  | F | 5                |
+                  ---    ---    ---                   |
+                   \  \ _ /       |                   |
+                    \    / \ _    |                   |
+                     \  /      \  |                   |
+                      ---      ---                    |
+Level 1            1 | B |    | C | 2                 |
+                      ---      ---                    |
+                        \      /                      |
+                         \    /                      \ /
+                           ---
+Level 0                 0 | A |                (more specialized)
+                           ---
+
+=cut
+
+{
+    package Test::O;
+    use mro 'c3'; 
+    
+    package Test::F;   
+    use mro 'c3';  
+    use base 'Test::O';        
+    
+    package Test::E;
+    use base 'Test::O';    
+    use mro 'c3';     
+    
+    sub C_or_E { 'Test::E' }
+
+    package Test::D;
+    use mro 'c3'; 
+    use base 'Test::O';     
+    
+    sub C_or_D { 'Test::D' }       
+      
+    package Test::C;
+    use base ('Test::D', 'Test::F');
+    use mro 'c3'; 
+    
+    sub C_or_D { 'Test::C' }
+    sub C_or_E { 'Test::C' }    
+        
+    package Test::B;    
+    use mro 'c3'; 
+    use base ('Test::D', 'Test::E');    
+        
+    package Test::A;    
+    use base ('Test::B', 'Test::C');
+    use mro 'c3';    
+}
+
+is_deeply(
+    mro::get_linear_isa('Test::F'),
+    [ qw(Test::F Test::O) ],
+    '... got the right MRO for Test::F');
+
+is_deeply(
+    mro::get_linear_isa('Test::E'),
+    [ qw(Test::E Test::O) ],
+    '... got the right MRO for Test::E');    
+
+is_deeply(
+    mro::get_linear_isa('Test::D'),
+    [ qw(Test::D Test::O) ],
+    '... got the right MRO for Test::D');       
+
+is_deeply(
+    mro::get_linear_isa('Test::C'),
+    [ qw(Test::C Test::D Test::F Test::O) ],
+    '... got the right MRO for Test::C'); 
+
+is_deeply(
+    mro::get_linear_isa('Test::B'),
+    [ qw(Test::B Test::D Test::E Test::O) ],
+    '... got the right MRO for Test::B');     
+
+is_deeply(
+    mro::get_linear_isa('Test::A'),
+    [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ],
+    '... got the right MRO for Test::A');  
+    
+is(Test::A->C_or_D, 'Test::C', '... got the expected method output');
+is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output');
+is(Test::A->C_or_E, 'Test::C', '... got the expected method output');
+is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output');
diff --git a/t/mro/basic_02_dfs.t b/t/mro/basic_02_dfs.t
new file mode 100644 (file)
index 0000000..bbce6a0
--- /dev/null
@@ -0,0 +1,121 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 10;
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My first example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(D,E): pass
+class A(B,C): pass
+
+
+                          6
+                         ---
+Level 3                 | O |                  (more general)
+                      /  ---  \
+                     /    |    \                      |
+                    /     |     \                     |
+                   /      |      \                    |
+                  ---    ---    ---                   |
+Level 2        3 | D | 4| E |  | F | 5                |
+                  ---    ---    ---                   |
+                   \  \ _ /       |                   |
+                    \    / \ _    |                   |
+                     \  /      \  |                   |
+                      ---      ---                    |
+Level 1            1 | B |    | C | 2                 |
+                      ---      ---                    |
+                        \      /                      |
+                         \    /                      \ /
+                           ---
+Level 0                 0 | A |                (more specialized)
+                           ---
+
+=cut
+
+{
+    package Test::O;
+    use mro 'dfs'; 
+    
+    package Test::F;   
+    use mro 'dfs';  
+    use base 'Test::O';        
+    
+    package Test::E;
+    use base 'Test::O';    
+    use mro 'dfs';     
+    
+    sub C_or_E { 'Test::E' }
+
+    package Test::D;
+    use mro 'dfs'; 
+    use base 'Test::O';     
+    
+    sub C_or_D { 'Test::D' }       
+      
+    package Test::C;
+    use base ('Test::D', 'Test::F');
+    use mro 'dfs'; 
+    
+    sub C_or_D { 'Test::C' }
+    sub C_or_E { 'Test::C' }    
+        
+    package Test::B;    
+    use mro 'dfs'; 
+    use base ('Test::D', 'Test::E');    
+        
+    package Test::A;    
+    use base ('Test::B', 'Test::C');
+    use mro 'dfs';    
+}
+
+is_deeply(
+    mro::get_linear_isa('Test::F'),
+    [ qw(Test::F Test::O) ],
+    '... got the right MRO for Test::F');
+
+is_deeply(
+    mro::get_linear_isa('Test::E'),
+    [ qw(Test::E Test::O) ],
+    '... got the right MRO for Test::E');    
+
+is_deeply(
+    mro::get_linear_isa('Test::D'),
+    [ qw(Test::D Test::O) ],
+    '... got the right MRO for Test::D');       
+
+is_deeply(
+    mro::get_linear_isa('Test::C'),
+    [ qw(Test::C Test::D Test::O Test::F) ],
+    '... got the right MRO for Test::C'); 
+
+is_deeply(
+    mro::get_linear_isa('Test::B'),
+    [ qw(Test::B Test::D Test::O Test::E) ],
+    '... got the right MRO for Test::B');     
+
+is_deeply(
+    mro::get_linear_isa('Test::A'),
+    [ qw(Test::A Test::B Test::D Test::O Test::E Test::C Test::F) ],
+    '... got the right MRO for Test::A');  
+    
+is(Test::A->C_or_D, 'Test::D', '... got the expected method output');
+is(Test::A->can('C_or_D')->(), 'Test::D', '... can got the expected method output');
+is(Test::A->C_or_E, 'Test::E', '... got the expected method output');
+is(Test::A->can('C_or_E')->(), 'Test::E', '... can got the expected method output');
diff --git a/t/mro/basic_03_c3.t b/t/mro/basic_03_c3.t
new file mode 100644 (file)
index 0000000..08dfea8
--- /dev/null
@@ -0,0 +1,107 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 4;
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My second example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(E,D): pass
+class A(B,C): pass
+
+                           6
+                          ---
+Level 3                  | O |
+                       /  ---  \
+                      /    |    \
+                     /     |     \
+                    /      |      \
+                  ---     ---    ---
+Level 2        2 | E | 4 | D |  | F | 5
+                  ---     ---    ---
+                   \      / \     /
+                    \    /   \   /
+                     \  /     \ /
+                      ---     ---
+Level 1            1 | B |   | C | 3
+                      ---     ---
+                       \       /
+                        \     /
+                          ---
+Level 0                0 | A |
+                          ---
+
+>>> A.mro()
+(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
+<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
+<type 'object'>)
+
+=cut
+
+{
+    package Test::O;
+    use mro 'c3';
+    
+    sub O_or_D { 'Test::O' }
+    sub O_or_F { 'Test::O' }    
+    
+    package Test::F;
+    use base 'Test::O';
+    use mro 'c3';
+    
+    sub O_or_F { 'Test::F' }    
+    
+    package Test::E;
+    use base 'Test::O';
+    use mro 'c3';
+        
+    package Test::D;
+    use base 'Test::O';    
+    use mro 'c3';
+    
+    sub O_or_D { 'Test::D' }
+    sub C_or_D { 'Test::D' }
+        
+    package Test::C;
+    use base ('Test::D', 'Test::F');
+    use mro 'c3';    
+
+    sub C_or_D { 'Test::C' }
+    
+    package Test::B;
+    use base ('Test::E', 'Test::D');
+    use mro 'c3';
+        
+    package Test::A;
+    use base ('Test::B', 'Test::C');
+    use mro 'c3';
+}
+
+is_deeply(
+    mro::get_linear_isa('Test::A'),
+    [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ],
+    '... got the right MRO for Test::A');      
+    
+is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch');    
+is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch');   
+
+# NOTE: 
+# this test is particularly interesting because the p5 dispatch
+# would actually call Test::D before Test::C and Test::D is a
+# subclass of Test::C 
+is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch');    
diff --git a/t/mro/basic_03_dfs.t b/t/mro/basic_03_dfs.t
new file mode 100644 (file)
index 0000000..d2af5b2
--- /dev/null
@@ -0,0 +1,107 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 4;
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My second example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(E,D): pass
+class A(B,C): pass
+
+                           6
+                          ---
+Level 3                  | O |
+                       /  ---  \
+                      /    |    \
+                     /     |     \
+                    /      |      \
+                  ---     ---    ---
+Level 2        2 | E | 4 | D |  | F | 5
+                  ---     ---    ---
+                   \      / \     /
+                    \    /   \   /
+                     \  /     \ /
+                      ---     ---
+Level 1            1 | B |   | C | 3
+                      ---     ---
+                       \       /
+                        \     /
+                          ---
+Level 0                0 | A |
+                          ---
+
+>>> A.mro()
+(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
+<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
+<type 'object'>)
+
+=cut
+
+{
+    package Test::O;
+    use mro 'dfs';
+    
+    sub O_or_D { 'Test::O' }
+    sub O_or_F { 'Test::O' }    
+    
+    package Test::F;
+    use base 'Test::O';
+    use mro 'dfs';
+    
+    sub O_or_F { 'Test::F' }    
+    
+    package Test::E;
+    use base 'Test::O';
+    use mro 'dfs';
+        
+    package Test::D;
+    use base 'Test::O';    
+    use mro 'dfs';
+    
+    sub O_or_D { 'Test::D' }
+    sub C_or_D { 'Test::D' }
+        
+    package Test::C;
+    use base ('Test::D', 'Test::F');
+    use mro 'dfs';    
+
+    sub C_or_D { 'Test::C' }
+    
+    package Test::B;
+    use base ('Test::E', 'Test::D');
+    use mro 'dfs';
+        
+    package Test::A;
+    use base ('Test::B', 'Test::C');
+    use mro 'dfs';
+}
+
+is_deeply(
+    mro::get_linear_isa('Test::A'),
+    [ qw(Test::A Test::B Test::E Test::O Test::D Test::C Test::F) ],
+    '... got the right MRO for Test::A');      
+    
+is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch');    
+is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch');   
+
+# NOTE: 
+# this test is particularly interesting because the p5 dispatch
+# would actually call Test::D before Test::C and Test::D is a
+# subclass of Test::C 
+is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch');    
diff --git a/t/mro/basic_04_c3.t b/t/mro/basic_04_c3.t
new file mode 100644 (file)
index 0000000..f7e92ec
--- /dev/null
@@ -0,0 +1,40 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 1;
+
+=pod 
+
+From the parrot test t/pmc/object-meths.t
+
+ A   B A   E
+  \ /   \ /
+   C     D
+    \   /
+     \ /
+      F
+
+=cut
+
+{
+    package t::lib::A; use mro 'c3';
+    package t::lib::B; use mro 'c3';
+    package t::lib::E; use mro 'c3';
+    package t::lib::C; use mro 'c3'; use base ('t::lib::A', 't::lib::B');
+    package t::lib::D; use mro 'c3'; use base ('t::lib::A', 't::lib::E');
+    package t::lib::F; use mro 'c3'; use base ('t::lib::C', 't::lib::D');
+}
+
+is_deeply(
+    mro::get_linear_isa('t::lib::F'),
+    [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ],
+    '... got the right MRO for t::lib::F');  
+
diff --git a/t/mro/basic_04_dfs.t b/t/mro/basic_04_dfs.t
new file mode 100644 (file)
index 0000000..bb6a352
--- /dev/null
@@ -0,0 +1,40 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 1;
+
+=pod 
+
+From the parrot test t/pmc/object-meths.t
+
+ A   B A   E
+  \ /   \ /
+   C     D
+    \   /
+     \ /
+      F
+
+=cut
+
+{
+    package t::lib::A; use mro 'dfs';
+    package t::lib::B; use mro 'dfs';
+    package t::lib::E; use mro 'dfs';
+    package t::lib::C; use mro 'dfs'; use base ('t::lib::A', 't::lib::B');
+    package t::lib::D; use mro 'dfs'; use base ('t::lib::A', 't::lib::E');
+    package t::lib::F; use mro 'dfs'; use base ('t::lib::C', 't::lib::D');
+}
+
+is_deeply(
+    mro::get_linear_isa('t::lib::F'),
+    [ qw(t::lib::F t::lib::C t::lib::A t::lib::B t::lib::D t::lib::E) ],
+    '... got the right MRO for t::lib::F');  
+
diff --git a/t/mro/basic_05_c3.t b/t/mro/basic_05_c3.t
new file mode 100644 (file)
index 0000000..91f2e35
--- /dev/null
@@ -0,0 +1,61 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 2;
+
+=pod
+
+This tests a strange bug found by Matt S. Trout 
+while building DBIx::Class. Thanks Matt!!!! 
+
+   <A>
+  /   \
+<C>   <B>
+  \   /
+   <D>
+
+=cut
+
+{
+    package Diamond_A;
+    use mro 'c3'; 
+
+    sub foo { 'Diamond_A::foo' }
+}
+{
+    package Diamond_B;
+    use base 'Diamond_A';
+    use mro 'c3';     
+
+    sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
+}
+{
+    package Diamond_C;
+    use mro 'c3';    
+    use base 'Diamond_A';     
+
+}
+{
+    package Diamond_D;
+    use base ('Diamond_C', 'Diamond_B');
+    use mro 'c3';    
+    
+    sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }    
+}
+
+is_deeply(
+    mro::get_linear_isa('Diamond_D'),
+    [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ],
+    '... got the right MRO for Diamond_D');
+
+is(Diamond_D->foo, 
+   'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo', 
+   '... got the right next::method dispatch path');
diff --git a/t/mro/basic_05_dfs.t b/t/mro/basic_05_dfs.t
new file mode 100644 (file)
index 0000000..187a640
--- /dev/null
@@ -0,0 +1,61 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 2;
+
+=pod
+
+This tests a strange bug found by Matt S. Trout 
+while building DBIx::Class. Thanks Matt!!!! 
+
+   <A>
+  /   \
+<C>   <B>
+  \   /
+   <D>
+
+=cut
+
+{
+    package Diamond_A;
+    use mro 'dfs'; 
+
+    sub foo { 'Diamond_A::foo' }
+}
+{
+    package Diamond_B;
+    use base 'Diamond_A';
+    use mro 'dfs';     
+
+    sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
+}
+{
+    package Diamond_C;
+    use mro 'dfs';    
+    use base 'Diamond_A';     
+
+}
+{
+    package Diamond_D;
+    use base ('Diamond_C', 'Diamond_B');
+    use mro 'dfs';    
+    
+    sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }    
+}
+
+is_deeply(
+    mro::get_linear_isa('Diamond_D'),
+    [ qw(Diamond_D Diamond_C Diamond_A Diamond_B) ],
+    '... got the right MRO for Diamond_D');
+
+is(Diamond_D->foo, 
+   'Diamond_D::foo => Diamond_A::foo', 
+   '... got the right next::method dispatch path');
diff --git a/t/mro/c3_with_overload.t b/t/mro/c3_with_overload.t
new file mode 100644 (file)
index 0000000..88170f3
--- /dev/null
@@ -0,0 +1,47 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+{
+    package BaseTest;
+    use strict;
+    use warnings;
+    use mro 'c3';
+    
+    package OverloadingTest;
+    use strict;
+    use warnings;
+    use mro 'c3';
+    use base 'BaseTest';        
+    use overload '""' => sub { ref(shift) . " stringified" },
+                 fallback => 1;
+    
+    sub new { bless {} => shift }    
+    
+    package InheritingFromOverloadedTest;
+    use strict;
+    use warnings;
+    use base 'OverloadingTest';
+    use mro 'c3';
+}
+
+my $x = InheritingFromOverloadedTest->new();
+isa_ok($x, 'InheritingFromOverloadedTest');
+
+my $y = OverloadingTest->new();
+isa_ok($y, 'OverloadingTest');
+
+is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
+is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
+
+ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
+
+my $result;
+eval { 
+    $result = $x eq 'InheritingFromOverloadedTest stringified' 
+};
+ok(!$@, '... this should not throw an exception');
+ok($result, '... and we should get the true value');
diff --git a/t/mro/complex_c3.t b/t/mro/complex_c3.t
new file mode 100644 (file)
index 0000000..72c9c02
--- /dev/null
@@ -0,0 +1,148 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 12;
+
+=pod
+
+This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
+
+               ---     ---     ---
+Level 5     8 | A | 9 | B | A | C |    (More General)
+               ---     ---     ---       V
+                  \     |     /          |
+                   \    |    /           |
+                    \   |   /            |
+                     \  |  /             |
+                       ---               |
+Level 4             7 | D |              |
+                       ---               |
+                      /   \              |
+                     /     \             |
+                  ---       ---          |
+Level 3        4 | G |   6 | E |         |
+                  ---       ---          |
+                   |         |           |
+                   |         |           |
+                  ---       ---          |
+Level 2        3 | H |   5 | F |         |
+                  ---       ---          |
+                      \   /  |           |
+                       \ /   |           |
+                        \    |           |
+                       / \   |           |
+                      /   \  |           |
+                  ---       ---          |
+Level 1        1 | J |   2 | I |         |
+                  ---       ---          |
+                    \       /            |
+                     \     /             |
+                       ---               v
+Level 0             0 | K |            (More Specialized)
+                       ---
+
+
+0123456789A
+KJIHGFEDABC
+
+=cut
+
+{
+    package Test::A; use mro 'c3';
+
+    package Test::B; use mro 'c3';
+
+    package Test::C; use mro 'c3';
+
+    package Test::D; use mro 'c3';
+    use base qw/Test::A Test::B Test::C/;
+
+    package Test::E; use mro 'c3';
+    use base qw/Test::D/;
+
+    package Test::F; use mro 'c3';
+    use base qw/Test::E/;
+    sub testmeth { "wrong" }
+
+    package Test::G; use mro 'c3';
+    use base qw/Test::D/;
+
+    package Test::H; use mro 'c3';
+    use base qw/Test::G/;
+
+    package Test::I; use mro 'c3';
+    use base qw/Test::H Test::F/;
+    sub testmeth { "right" }
+
+    package Test::J; use mro 'c3';
+    use base qw/Test::F/;
+
+    package Test::K; use mro 'c3';
+    use base qw/Test::J Test::I/;
+    sub testmeth { shift->next::method }
+}
+
+is_deeply(
+    mro::get_linear_isa('Test::A'),
+    [ qw(Test::A) ],
+    '... got the right C3 merge order for Test::A');
+
+is_deeply(
+    mro::get_linear_isa('Test::B'),
+    [ qw(Test::B) ],
+    '... got the right C3 merge order for Test::B');
+
+is_deeply(
+    mro::get_linear_isa('Test::C'),
+    [ qw(Test::C) ],
+    '... got the right C3 merge order for Test::C');
+
+is_deeply(
+    mro::get_linear_isa('Test::D'),
+    [ qw(Test::D Test::A Test::B Test::C) ],
+    '... got the right C3 merge order for Test::D');
+
+is_deeply(
+    mro::get_linear_isa('Test::E'),
+    [ qw(Test::E Test::D Test::A Test::B Test::C) ],
+    '... got the right C3 merge order for Test::E');
+
+is_deeply(
+    mro::get_linear_isa('Test::F'),
+    [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
+    '... got the right C3 merge order for Test::F');
+
+is_deeply(
+    mro::get_linear_isa('Test::G'),
+    [ qw(Test::G Test::D Test::A Test::B Test::C) ],
+    '... got the right C3 merge order for Test::G');
+
+is_deeply(
+    mro::get_linear_isa('Test::H'),
+    [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
+    '... got the right C3 merge order for Test::H');
+
+is_deeply(
+    mro::get_linear_isa('Test::I'),
+    [ qw(Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
+    '... got the right C3 merge order for Test::I');
+
+is_deeply(
+    mro::get_linear_isa('Test::J'),
+    [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
+    '... got the right C3 merge order for Test::J');
+
+is_deeply(
+    mro::get_linear_isa('Test::K'),
+    [ qw(Test::K Test::J Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
+    '... got the right C3 merge order for Test::K');
+
+is(Test::K->testmeth(), "right", 'next::method working ok');
diff --git a/t/mro/complex_dfs.t b/t/mro/complex_dfs.t
new file mode 100644 (file)
index 0000000..d864555
--- /dev/null
@@ -0,0 +1,143 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 11;
+
+=pod
+
+This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
+
+               ---     ---     ---
+Level 5     8 | A | 9 | B | A | C |    (More General)
+               ---     ---     ---       V
+                  \     |     /          |
+                   \    |    /           |
+                    \   |   /            |
+                     \  |  /             |
+                       ---               |
+Level 4             7 | D |              |
+                       ---               |
+                      /   \              |
+                     /     \             |
+                  ---       ---          |
+Level 3        4 | G |   6 | E |         |
+                  ---       ---          |
+                   |         |           |
+                   |         |           |
+                  ---       ---          |
+Level 2        3 | H |   5 | F |         |
+                  ---       ---          |
+                      \   /  |           |
+                       \ /   |           |
+                        \    |           |
+                       / \   |           |
+                      /   \  |           |
+                  ---       ---          |
+Level 1        1 | J |   2 | I |         |
+                  ---       ---          |
+                    \       /            |
+                     \     /             |
+                       ---               v
+Level 0             0 | K |            (More Specialized)
+                       ---
+
+
+0123456789A
+KJIHGFEDABC
+
+=cut
+
+{
+    package Test::A; use mro 'dfs';
+
+    package Test::B; use mro 'dfs';
+
+    package Test::C; use mro 'dfs';
+
+    package Test::D; use mro 'dfs';
+    use base qw/Test::A Test::B Test::C/;
+
+    package Test::E; use mro 'dfs';
+    use base qw/Test::D/;
+
+    package Test::F; use mro 'dfs';
+    use base qw/Test::E/;
+
+    package Test::G; use mro 'dfs';
+    use base qw/Test::D/;
+
+    package Test::H; use mro 'dfs';
+    use base qw/Test::G/;
+
+    package Test::I; use mro 'dfs';
+    use base qw/Test::H Test::F/;
+
+    package Test::J; use mro 'dfs';
+    use base qw/Test::F/;
+
+    package Test::K; use mro 'dfs';
+    use base qw/Test::J Test::I/;
+}
+
+is_deeply(
+    mro::get_linear_isa('Test::A'),
+    [ qw(Test::A) ],
+    '... got the right DFS merge order for Test::A');
+
+is_deeply(
+    mro::get_linear_isa('Test::B'),
+    [ qw(Test::B) ],
+    '... got the right DFS merge order for Test::B');
+
+is_deeply(
+    mro::get_linear_isa('Test::C'),
+    [ qw(Test::C) ],
+    '... got the right DFS merge order for Test::C');
+
+is_deeply(
+    mro::get_linear_isa('Test::D'),
+    [ qw(Test::D Test::A Test::B Test::C) ],
+    '... got the right DFS merge order for Test::D');
+
+is_deeply(
+    mro::get_linear_isa('Test::E'),
+    [ qw(Test::E Test::D Test::A Test::B Test::C) ],
+    '... got the right DFS merge order for Test::E');
+
+is_deeply(
+    mro::get_linear_isa('Test::F'),
+    [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
+    '... got the right DFS merge order for Test::F');
+
+is_deeply(
+    mro::get_linear_isa('Test::G'),
+    [ qw(Test::G Test::D Test::A Test::B Test::C) ],
+    '... got the right DFS merge order for Test::G');
+
+is_deeply(
+    mro::get_linear_isa('Test::H'),
+    [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
+    '... got the right DFS merge order for Test::H');
+
+is_deeply(
+    mro::get_linear_isa('Test::I'),
+    [ qw(Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E) ],
+    '... got the right DFS merge order for Test::I');
+
+is_deeply(
+    mro::get_linear_isa('Test::J'),
+    [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
+    '... got the right DFS merge order for Test::J');
+
+is_deeply(
+    mro::get_linear_isa('Test::K'),
+    [ qw(Test::K Test::J Test::F Test::E Test::D Test::A Test::B Test::C Test::I Test::H Test::G) ],
+    '... got the right DFS merge order for Test::K');
diff --git a/t/mro/dbic_c3.t b/t/mro/dbic_c3.t
new file mode 100644 (file)
index 0000000..a59f334
--- /dev/null
@@ -0,0 +1,125 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 1;
+
+=pod
+
+This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
+(No ASCII art this time, this graph is insane)
+
+The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
+
+=cut
+
+{
+    package xx::DBIx::Class::Core; use mro 'c3';
+    our @ISA = qw/
+      xx::DBIx::Class::Serialize::Storable
+      xx::DBIx::Class::InflateColumn
+      xx::DBIx::Class::Relationship
+      xx::DBIx::Class::PK::Auto
+      xx::DBIx::Class::PK
+      xx::DBIx::Class::Row
+      xx::DBIx::Class::ResultSourceProxy::Table
+      xx::DBIx::Class::AccessorGroup
+    /;
+
+    package xx::DBIx::Class::InflateColumn; use mro 'c3';
+    our @ISA = qw/ xx::DBIx::Class::Row /;
+
+    package xx::DBIx::Class::Row; use mro 'c3';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::DBIx::Class; use mro 'c3';
+    our @ISA = qw/
+      xx::DBIx::Class::Componentised
+      xx::Class::Data::Accessor
+    /;
+
+    package xx::DBIx::Class::Relationship; use mro 'c3';
+    our @ISA = qw/
+      xx::DBIx::Class::Relationship::Helpers
+      xx::DBIx::Class::Relationship::Accessor
+      xx::DBIx::Class::Relationship::CascadeActions
+      xx::DBIx::Class::Relationship::ProxyMethods
+      xx::DBIx::Class::Relationship::Base
+      xx::DBIx::Class
+    /;
+
+    package xx::DBIx::Class::Relationship::Helpers; use mro 'c3';
+    our @ISA = qw/
+      xx::DBIx::Class::Relationship::HasMany
+      xx::DBIx::Class::Relationship::HasOne
+      xx::DBIx::Class::Relationship::BelongsTo
+      xx::DBIx::Class::Relationship::ManyToMany
+    /;
+
+    package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::DBIx::Class::Relationship::Base; use mro 'c3';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::DBIx::Class::PK::Auto; use mro 'c3';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::DBIx::Class::PK; use mro 'c3';
+    our @ISA = qw/ xx::DBIx::Class::Row /;
+
+    package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3';
+    our @ISA = qw/
+      xx::DBIx::Class::AccessorGroup
+      xx::DBIx::Class::ResultSourceProxy
+    /;
+
+    package xx::DBIx::Class::ResultSourceProxy; use mro 'c3';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::Class::Data::Accessor; our @ISA = (); use mro 'c3';
+    package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'c3';
+    package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'c3';
+    package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'c3';
+    package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'c3';
+    package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'c3';
+    package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'c3';
+    package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'c3';
+    package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'c3';
+    package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'c3';
+}
+
+is_deeply(
+    mro::get_linear_isa('xx::DBIx::Class::Core'),
+    [qw/
+        xx::DBIx::Class::Core
+        xx::DBIx::Class::Serialize::Storable
+        xx::DBIx::Class::InflateColumn
+        xx::DBIx::Class::Relationship
+        xx::DBIx::Class::Relationship::Helpers
+        xx::DBIx::Class::Relationship::HasMany
+        xx::DBIx::Class::Relationship::HasOne
+        xx::DBIx::Class::Relationship::BelongsTo
+        xx::DBIx::Class::Relationship::ManyToMany
+        xx::DBIx::Class::Relationship::Accessor
+        xx::DBIx::Class::Relationship::CascadeActions
+        xx::DBIx::Class::Relationship::ProxyMethods
+        xx::DBIx::Class::Relationship::Base
+        xx::DBIx::Class::PK::Auto
+        xx::DBIx::Class::PK
+        xx::DBIx::Class::Row
+        xx::DBIx::Class::ResultSourceProxy::Table
+        xx::DBIx::Class::AccessorGroup
+        xx::DBIx::Class::ResultSourceProxy
+        xx::DBIx::Class
+        xx::DBIx::Class::Componentised
+        xx::Class::Data::Accessor
+    /],
+    '... got the right C3 merge order for xx::DBIx::Class::Core');
diff --git a/t/mro/dbic_dfs.t b/t/mro/dbic_dfs.t
new file mode 100644 (file)
index 0000000..f823147
--- /dev/null
@@ -0,0 +1,125 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 1;
+
+=pod
+
+This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
+(No ASCII art this time, this graph is insane)
+
+The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
+
+=cut
+
+{
+    package xx::DBIx::Class::Core; use mro 'dfs';
+    our @ISA = qw/
+      xx::DBIx::Class::Serialize::Storable
+      xx::DBIx::Class::InflateColumn
+      xx::DBIx::Class::Relationship
+      xx::DBIx::Class::PK::Auto
+      xx::DBIx::Class::PK
+      xx::DBIx::Class::Row
+      xx::DBIx::Class::ResultSourceProxy::Table
+      xx::DBIx::Class::AccessorGroup
+    /;
+
+    package xx::DBIx::Class::InflateColumn; use mro 'dfs';
+    our @ISA = qw/ xx::DBIx::Class::Row /;
+
+    package xx::DBIx::Class::Row; use mro 'dfs';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::DBIx::Class; use mro 'dfs';
+    our @ISA = qw/
+      xx::DBIx::Class::Componentised
+      xx::Class::Data::Accessor
+    /;
+
+    package xx::DBIx::Class::Relationship; use mro 'dfs';
+    our @ISA = qw/
+      xx::DBIx::Class::Relationship::Helpers
+      xx::DBIx::Class::Relationship::Accessor
+      xx::DBIx::Class::Relationship::CascadeActions
+      xx::DBIx::Class::Relationship::ProxyMethods
+      xx::DBIx::Class::Relationship::Base
+      xx::DBIx::Class
+    /;
+
+    package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs';
+    our @ISA = qw/
+      xx::DBIx::Class::Relationship::HasMany
+      xx::DBIx::Class::Relationship::HasOne
+      xx::DBIx::Class::Relationship::BelongsTo
+      xx::DBIx::Class::Relationship::ManyToMany
+    /;
+
+    package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::DBIx::Class::Relationship::Base; use mro 'dfs';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::DBIx::Class::PK::Auto; use mro 'dfs';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::DBIx::Class::PK; use mro 'dfs';
+    our @ISA = qw/ xx::DBIx::Class::Row /;
+
+    package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs';
+    our @ISA = qw/
+      xx::DBIx::Class::AccessorGroup
+      xx::DBIx::Class::ResultSourceProxy
+    /;
+
+    package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs';
+    our @ISA = qw/ xx::DBIx::Class /;
+
+    package xx::Class::Data::Accessor; our @ISA = (); use mro 'dfs';
+    package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'dfs';
+    package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'dfs';
+    package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'dfs';
+    package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'dfs';
+    package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'dfs';
+    package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'dfs';
+    package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'dfs';
+    package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'dfs';
+    package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'dfs';
+}
+
+is_deeply(
+    mro::get_linear_isa('xx::DBIx::Class::Core'),
+    [qw/
+        xx::DBIx::Class::Core
+        xx::DBIx::Class::Serialize::Storable
+        xx::DBIx::Class::InflateColumn
+        xx::DBIx::Class::Row
+        xx::DBIx::Class
+        xx::DBIx::Class::Componentised
+        xx::Class::Data::Accessor
+        xx::DBIx::Class::Relationship
+        xx::DBIx::Class::Relationship::Helpers
+        xx::DBIx::Class::Relationship::HasMany
+        xx::DBIx::Class::Relationship::HasOne
+        xx::DBIx::Class::Relationship::BelongsTo
+        xx::DBIx::Class::Relationship::ManyToMany
+        xx::DBIx::Class::Relationship::Accessor
+        xx::DBIx::Class::Relationship::CascadeActions
+        xx::DBIx::Class::Relationship::ProxyMethods
+        xx::DBIx::Class::Relationship::Base
+        xx::DBIx::Class::PK::Auto
+        xx::DBIx::Class::PK
+        xx::DBIx::Class::ResultSourceProxy::Table
+        xx::DBIx::Class::AccessorGroup
+        xx::DBIx::Class::ResultSourceProxy
+    /],
+    '... got the right DFS merge order for xx::DBIx::Class::Core');
diff --git a/t/mro/inconsistent_c3.t b/t/mro/inconsistent_c3.t
new file mode 100644 (file)
index 0000000..07f83c2
--- /dev/null
@@ -0,0 +1,47 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 1;
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"Serious order disagreement" # From Guido
+class O: pass
+class X(O): pass
+class Y(O): pass
+class A(X,Y): pass
+class B(Y,X): pass
+try:
+    class Z(A,B): pass #creates Z(A,B) in Python 2.2
+except TypeError:
+    pass # Z(A,B) cannot be created in Python 2.3
+
+=cut
+
+{
+    package X;
+    
+    package Y;
+    
+    package XY;
+    our @ISA = ('X', 'Y');
+    
+    package YX;
+    our @ISA = ('Y', 'X');
+
+    package Z;
+    our @ISA = ('XY', 'YX');
+}
+
+eval { mro::get_linear_isa('Z', 'c3') };
+like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
diff --git a/t/mro/method_caching.t b/t/mro/method_caching.t
new file mode 100644 (file)
index 0000000..8013a0a
--- /dev/null
@@ -0,0 +1,46 @@
+#!./perl
+
+use strict;
+use warnings;
+no warnings 'redefine'; # we do a lot of this
+no warnings 'prototype'; # we do a lot of this
+
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More;
+
+{
+    package MCTest::Base;
+    sub foo { return $_[1]+1 };
+    sub bar { 42 };
+
+    package MCTest::Derived;
+    our @ISA = qw/MCTest::Base/;
+}
+
+# These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be
+my @testsubs = (
+    sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); },
+    sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); },
+    sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); },
+    sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); },
+    sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); },
+    sub { is(MCTest::Derived->foo(0), 5); },
+    sub { sub FFF { $_[1]+9 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 9); },
+    sub { is(MCTest::Derived->foo(0), 5); },
+    sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
+    sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
+    sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
+    sub { sub MCTest::Base::foo($); *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
+    sub { *XYZ = sub { $_[1]+8 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 8); },
+);
+
+plan tests => scalar(@testsubs) + 1;
+
+is(MCTest::Derived->foo(0), 1);
+$_->() for (@testsubs);
diff --git a/t/mro/next_method.t b/t/mro/next_method.t
new file mode 100644 (file)
index 0000000..b0bb789
--- /dev/null
@@ -0,0 +1,65 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+=pod
+
+This tests the classic diamond inheritence pattern.
+
+   <A>
+  /   \
+<B>   <C>
+  \   /
+   <D>
+
+=cut
+
+{
+    package Diamond_A;
+    use mro 'c3'; 
+    sub hello { 'Diamond_A::hello' }
+    sub foo { 'Diamond_A::foo' }       
+}
+{
+    package Diamond_B;
+    use base 'Diamond_A';
+    use mro 'c3';     
+    sub foo { 'Diamond_B::foo => ' . (shift)->next::method() }       
+}
+{
+    package Diamond_C;
+    use mro 'c3';    
+    use base 'Diamond_A';     
+
+    sub hello { 'Diamond_C::hello => ' . (shift)->next::method() }
+    sub foo { 'Diamond_C::foo => ' . (shift)->next::method() }   
+}
+{
+    package Diamond_D;
+    use base ('Diamond_B', 'Diamond_C');
+    use mro 'c3'; 
+    
+    sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }   
+}
+
+is_deeply(
+    mro::get_linear_isa('Diamond_D'),
+    [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+    '... got the right MRO for Diamond_D');
+
+is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected');
+
+is(Diamond_D->can('hello')->('Diamond_D'), 
+   'Diamond_C::hello => Diamond_A::hello', 
+   '... can(method) resolved itself as expected');
+   
+is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'), 
+   'Diamond_C::hello => Diamond_A::hello', 
+   '... can(method) resolved itself as expected');
+
+is(Diamond_D->foo, 
+    'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo', 
+    '... method foo resolved itself as expected');
diff --git a/t/mro/next_method_edge_cases.t b/t/mro/next_method_edge_cases.t
new file mode 100644 (file)
index 0000000..496537c
--- /dev/null
@@ -0,0 +1,82 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+
+{
+
+    {
+        package Foo;
+        use strict;
+        use warnings;
+        use mro 'c3';
+        sub new { bless {}, $_[0] }
+        sub bar { 'Foo::bar' }
+    }
+
+    # call the submethod in the direct instance
+
+    my $foo = Foo->new();
+    isa_ok($foo, 'Foo');
+
+    can_ok($foo, 'bar');
+    is($foo->bar(), 'Foo::bar', '... got the right return value');    
+
+    # fail calling it from a subclass
+
+    {
+        package Bar;
+        use strict;
+        use warnings;
+        use mro 'c3';
+        our @ISA = ('Foo');
+    }  
+    
+    my $bar = Bar->new();
+    isa_ok($bar, 'Bar');
+    isa_ok($bar, 'Foo');    
+    
+    # test it working with with Sub::Name
+    SKIP: {    
+        eval 'use Sub::Name';
+        skip "Sub::Name is required for this test", 3 if $@;
+    
+        my $m = sub { (shift)->next::method() };
+        Sub::Name::subname('Bar::bar', $m);
+        {
+            no strict 'refs';
+            *{'Bar::bar'} = $m;
+        }
+
+        can_ok($bar, 'bar');
+        my $value = eval { $bar->bar() };
+        ok(!$@, '... calling bar() succedded') || diag $@;
+        is($value, 'Foo::bar', '... got the right return value too');
+    }
+    
+    # test it failing without Sub::Name
+    {
+        package Baz;
+        use strict;
+        use warnings;
+        use mro 'c3';
+        our @ISA = ('Foo');
+    }      
+    
+    my $baz = Baz->new();
+    isa_ok($baz, 'Baz');
+    isa_ok($baz, 'Foo');    
+    
+    {
+        my $m = sub { (shift)->next::method() };
+        {
+            no strict 'refs';
+            *{'Baz::bar'} = $m;
+        }
+
+        eval { $baz->bar() };
+        ok($@, '... calling bar() with next::method failed') || diag $@;
+    }    
+}
diff --git a/t/mro/next_method_in_anon.t b/t/mro/next_method_in_anon.t
new file mode 100644 (file)
index 0000000..e135d54
--- /dev/null
@@ -0,0 +1,57 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+=pod
+
+This tests the successful handling of a next::method call from within an
+anonymous subroutine.
+
+=cut
+
+{
+    package A;
+    use mro 'c3'; 
+
+    sub foo {
+      return 'A::foo';
+    }
+
+    sub bar {
+      return 'A::bar';
+    }
+}
+
+{
+    package B;
+    use base 'A';
+    use mro 'c3'; 
+    
+    sub foo {
+      my $code = sub {
+        return 'B::foo => ' . (shift)->next::method();
+      };
+      return (shift)->$code;
+    }
+
+    sub bar {
+      my $code1 = sub {
+        my $code2 = sub {
+          return 'B::bar => ' . (shift)->next::method();
+        };
+        return (shift)->$code2;
+      };
+      return (shift)->$code1;
+    }
+}
+
+is(B->foo, "B::foo => A::foo",
+   'method resolved inside anonymous sub');
+
+is(B->bar, "B::bar => A::bar",
+   'method resolved inside nested anonymous subs');
+
+
diff --git a/t/mro/next_method_in_eval.t b/t/mro/next_method_in_eval.t
new file mode 100644 (file)
index 0000000..d55ce80
--- /dev/null
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+=pod
+
+This tests the use of an eval{} block to wrap a next::method call.
+
+=cut
+
+{
+    package A;
+    use mro 'c3'; 
+
+    sub foo {
+      die 'A::foo died';
+      return 'A::foo succeeded';
+    }
+}
+
+{
+    package B;
+    use base 'A';
+    use mro 'c3'; 
+    
+    sub foo {
+      eval {
+        return 'B::foo => ' . (shift)->next::method();
+      };
+
+      if ($@) {
+        return $@;
+      }
+    }
+}
+
+like(B->foo, 
+   qr/^A::foo died/, 
+   'method resolved inside eval{}');
+
+
diff --git a/t/mro/next_method_skip.t b/t/mro/next_method_skip.t
new file mode 100644 (file)
index 0000000..6bd73d0
--- /dev/null
@@ -0,0 +1,75 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+
+=pod
+
+This tests the classic diamond inheritence pattern.
+
+   <A>
+  /   \
+<B>   <C>
+  \   /
+   <D>
+
+=cut
+
+{
+    package Diamond_A;
+    use mro 'c3'; 
+    sub bar { 'Diamond_A::bar' }        
+    sub baz { 'Diamond_A::baz' }
+}
+{
+    package Diamond_B;
+    use base 'Diamond_A';
+    use mro 'c3';    
+    sub baz { 'Diamond_B::baz => ' . (shift)->next::method() }         
+}
+{
+    package Diamond_C;
+    use mro 'c3';    
+    use base 'Diamond_A';     
+    sub foo { 'Diamond_C::foo' }   
+    sub buz { 'Diamond_C::buz' }     
+    
+    sub woz { 'Diamond_C::woz' }
+    sub maybe { 'Diamond_C::maybe' }         
+}
+{
+    package Diamond_D;
+    use base ('Diamond_B', 'Diamond_C');
+    use mro 'c3'; 
+    sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } 
+    sub bar { 'Diamond_D::bar => ' . (shift)->next::method() }   
+    sub buz { 'Diamond_D::buz => ' . (shift)->baz() }  
+    sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() }  
+    
+    sub woz { 'Diamond_D::woz can => ' . ((shift)->next::can() ? 1 : 0) }
+    sub noz { 'Diamond_D::noz can => ' . ((shift)->next::can() ? 1 : 0) }
+
+    sub maybe { 'Diamond_D::maybe => ' . ((shift)->maybe::next::method() || 0) }
+    sub moybe { 'Diamond_D::moybe => ' . ((shift)->maybe::next::method() || 0) }             
+
+}
+
+is_deeply(
+    mro::get_linear_isa('Diamond_D'),
+    [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+    '... got the right MRO for Diamond_D');
+
+is(Diamond_D->foo, 'Diamond_D::foo => Diamond_C::foo', '... skipped B and went to C correctly');
+is(Diamond_D->bar, 'Diamond_D::bar => Diamond_A::bar', '... skipped B & C and went to A correctly');
+is(Diamond_D->baz, 'Diamond_B::baz => Diamond_A::baz', '... called B method, skipped C and went to A correctly');
+is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... called D method dispatched to , different method correctly');
+eval { Diamond_D->fuz };
+like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there');
+
+is(Diamond_D->woz, 'Diamond_D::woz can => 1', '... can re-dispatch figured out correctly');
+is(Diamond_D->noz, 'Diamond_D::noz can => 0', '... cannot re-dispatch figured out correctly');
+
+is(Diamond_D->maybe, 'Diamond_D::maybe => Diamond_C::maybe', '... redispatched D to C when it exists');
+is(Diamond_D->moybe, 'Diamond_D::moybe => 0', '... quietly failed redispatch from D');
diff --git a/t/mro/next_method_used_with_NEXT.t b/t/mro/next_method_used_with_NEXT.t
new file mode 100644 (file)
index 0000000..f7a8c11
--- /dev/null
@@ -0,0 +1,53 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+    eval "use NEXT";
+    plan skip_all => "NEXT required for this test" if $@;
+    plan tests => 4;
+}
+
+{
+    package Foo;
+    use strict;
+    use warnings;
+    use mro 'c3';
+    
+    sub foo { 'Foo::foo' }
+    
+    package Fuz;
+    use strict;
+    use warnings;
+    use mro 'c3';
+    use base 'Foo';
+
+    sub foo { 'Fuz::foo => ' . (shift)->next::method }
+        
+    package Bar;
+    use strict;
+    use warnings;    
+    use mro 'c3';
+    use base 'Foo';
+
+    sub foo { 'Bar::foo => ' . (shift)->next::method }
+    
+    package Baz;
+    use strict;
+    use warnings;    
+    require NEXT; # load this as late as possible so we can catch the test skip
+
+    use base 'Bar', 'Fuz';
+    
+    sub foo { 'Baz::foo => ' . (shift)->NEXT::foo }    
+}
+
+is(Foo->foo, 'Foo::foo', '... got the right value from Foo->foo');
+is(Fuz->foo, 'Fuz::foo => Foo::foo', '... got the right value from Fuz->foo');
+is(Bar->foo, 'Bar::foo => Foo::foo', '... got the right value from Bar->foo');
+
+is(Baz->foo, 'Baz::foo => Bar::foo => Fuz::foo => Foo::foo', '... got the right value using NEXT in a subclass of a C3 class');
+
diff --git a/t/mro/overload_c3.t b/t/mro/overload_c3.t
new file mode 100644 (file)
index 0000000..e227dcd
--- /dev/null
@@ -0,0 +1,54 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 7;
+
+{
+    package BaseTest;
+    use strict;
+    use warnings;
+    use mro 'c3';
+    
+    package OverloadingTest;
+    use strict;
+    use warnings;
+    use mro 'c3';
+    use base 'BaseTest';        
+    use overload '""' => sub { ref(shift) . " stringified" },
+                 fallback => 1;
+    
+    sub new { bless {} => shift }    
+    
+    package InheritingFromOverloadedTest;
+    use strict;
+    use warnings;
+    use base 'OverloadingTest';
+    use mro 'c3';
+}
+
+my $x = InheritingFromOverloadedTest->new();
+isa_ok($x, 'InheritingFromOverloadedTest');
+
+my $y = OverloadingTest->new();
+isa_ok($y, 'OverloadingTest');
+
+is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
+is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
+
+ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
+
+my $result;
+eval { 
+    $result = $x eq 'InheritingFromOverloadedTest stringified' 
+};
+ok(!$@, '... this should not throw an exception');
+ok($result, '... and we should get the true value');
+
diff --git a/t/mro/overload_dfs.t b/t/mro/overload_dfs.t
new file mode 100644 (file)
index 0000000..98f9a2c
--- /dev/null
@@ -0,0 +1,54 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 7;
+
+{
+    package BaseTest;
+    use strict;
+    use warnings;
+    use mro 'dfs';
+    
+    package OverloadingTest;
+    use strict;
+    use warnings;
+    use mro 'dfs';
+    use base 'BaseTest';        
+    use overload '""' => sub { ref(shift) . " stringified" },
+                 fallback => 1;
+    
+    sub new { bless {} => shift }    
+    
+    package InheritingFromOverloadedTest;
+    use strict;
+    use warnings;
+    use base 'OverloadingTest';
+    use mro 'dfs';
+}
+
+my $x = InheritingFromOverloadedTest->new();
+isa_ok($x, 'InheritingFromOverloadedTest');
+
+my $y = OverloadingTest->new();
+isa_ok($y, 'OverloadingTest');
+
+is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
+is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
+
+ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
+
+my $result;
+eval { 
+    $result = $x eq 'InheritingFromOverloadedTest stringified' 
+};
+ok(!$@, '... this should not throw an exception');
+ok($result, '... and we should get the true value');
+
diff --git a/t/mro/recursion_c3.t b/t/mro/recursion_c3.t
new file mode 100644 (file)
index 0000000..60b174b
--- /dev/null
@@ -0,0 +1,88 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More;
+use mro;
+
+plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
+plan tests => 8;
+
+=pod
+
+These are like the 010_complex_merge_classless test,
+but an infinite loop has been made in the heirarchy,
+to test that we can fail cleanly instead of going
+into an infinite loop
+
+=cut
+
+# initial setup, everything sane
+{
+    package K;
+    our @ISA = qw/J I/;
+    package J;
+    our @ISA = qw/F/;
+    package I;
+    our @ISA = qw/H F/;
+    package H;
+    our @ISA = qw/G/;
+    package G;
+    our @ISA = qw/D/;
+    package F;
+    our @ISA = qw/E/;
+    package E;
+    our @ISA = qw/D/;
+    package D;
+    our @ISA = qw/A B C/;
+    package C;
+    our @ISA = qw//;
+    package B;
+    our @ISA = qw//;
+    package A;
+    our @ISA = qw//;
+}
+
+# A series of 8 abberations that would cause infinite loops,
+#  each one undoing the work of the previous
+my @loopies = (
+    sub { @E::ISA = qw/F/ },
+    sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
+    sub { @C::ISA = qw//; @A::ISA = qw/K/ },
+    sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
+    sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
+    sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
+    sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
+    sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
+);
+
+foreach my $loopy (@loopies) {
+    eval {
+        local $SIG{ALRM} = sub { die "ALRMTimeout" };
+        alarm(3);
+        $loopy->();
+        mro::get_linear_isa('K', 'c3');
+    };
+
+    if(my $err = $@) {
+        if($err =~ /ALRMTimeout/) {
+            ok(0, "Loop terminated by SIGALRM");
+        }
+        elsif($err =~ /Recursive inheritance detected/) {
+            ok(1, "Graceful exception thrown");
+        }
+        else {
+            ok(0, "Unrecognized exception: $err");
+        }
+    }
+    else {
+        ok(0, "Infinite loop apparently succeeded???");
+    }
+}
diff --git a/t/mro/recursion_dfs.t b/t/mro/recursion_dfs.t
new file mode 100644 (file)
index 0000000..a3d610e
--- /dev/null
@@ -0,0 +1,88 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More;
+use mro;
+
+plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
+plan tests => 8;
+
+=pod
+
+These are like the 010_complex_merge_classless test,
+but an infinite loop has been made in the heirarchy,
+to test that we can fail cleanly instead of going
+into an infinite loop
+
+=cut
+
+# initial setup, everything sane
+{
+    package K;
+    our @ISA = qw/J I/;
+    package J;
+    our @ISA = qw/F/;
+    package I;
+    our @ISA = qw/H F/;
+    package H;
+    our @ISA = qw/G/;
+    package G;
+    our @ISA = qw/D/;
+    package F;
+    our @ISA = qw/E/;
+    package E;
+    our @ISA = qw/D/;
+    package D;
+    our @ISA = qw/A B C/;
+    package C;
+    our @ISA = qw//;
+    package B;
+    our @ISA = qw//;
+    package A;
+    our @ISA = qw//;
+}
+
+# A series of 8 abberations that would cause infinite loops,
+#  each one undoing the work of the previous
+my @loopies = (
+    sub { @E::ISA = qw/F/ },
+    sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
+    sub { @C::ISA = qw//; @A::ISA = qw/K/ },
+    sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
+    sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
+    sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
+    sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
+    sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
+);
+
+foreach my $loopy (@loopies) {
+    eval {
+        local $SIG{ALRM} = sub { die "ALRMTimeout" };
+        alarm(3);
+        $loopy->();
+        mro::get_linear_isa('K', 'dfs');
+    };
+
+    if(my $err = $@) {
+        if($err =~ /ALRMTimeout/) {
+            ok(0, "Loop terminated by SIGALRM");
+        }
+        elsif($err =~ /Recursive inheritance detected/) {
+            ok(1, "Graceful exception thrown");
+        }
+        else {
+            ok(0, "Unrecognized exception: $err");
+        }
+    }
+    else {
+        ok(0, "Infinite loop apparently succeeded???");
+    }
+}
diff --git a/t/mro/vulcan_c3.t b/t/mro/vulcan_c3.t
new file mode 100644 (file)
index 0000000..9ac1c45
--- /dev/null
@@ -0,0 +1,73 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 1;
+use mro;
+
+=pod
+
+example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
+
+         Object
+           ^
+           |
+        LifeForm 
+         ^    ^
+        /      \
+   Sentient    BiPedal
+      ^          ^
+      |          |
+ Intelligent  Humanoid
+       ^        ^
+        \      /
+         Vulcan
+
+ define class <sentient> (<life-form>) end class;
+ define class <bipedal> (<life-form>) end class;
+ define class <intelligent> (<sentient>) end class;
+ define class <humanoid> (<bipedal>) end class;
+ define class <vulcan> (<intelligent>, <humanoid>) end class;
+
+=cut
+
+{
+    package Object;    
+    use mro 'c3';
+    
+    package LifeForm;
+    use mro 'c3';
+    use base 'Object';
+    
+    package Sentient;
+    use mro 'c3';
+    use base 'LifeForm';
+    
+    package BiPedal;
+    use mro 'c3';    
+    use base 'LifeForm';
+    
+    package Intelligent;
+    use mro 'c3';    
+    use base 'Sentient';
+    
+    package Humanoid;
+    use mro 'c3';    
+    use base 'BiPedal';
+    
+    package Vulcan;
+    use mro 'c3';    
+    use base ('Intelligent', 'Humanoid');
+}
+
+is_deeply(
+    mro::get_linear_isa('Vulcan'),
+    [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ],
+    '... got the right MRO for the Vulcan Dylan Example');  
diff --git a/t/mro/vulcan_dfs.t b/t/mro/vulcan_dfs.t
new file mode 100644 (file)
index 0000000..4941294
--- /dev/null
@@ -0,0 +1,73 @@
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 1;
+use mro;
+
+=pod
+
+example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
+
+         Object
+           ^
+           |
+        LifeForm 
+         ^    ^
+        /      \
+   Sentient    BiPedal
+      ^          ^
+      |          |
+ Intelligent  Humanoid
+       ^        ^
+        \      /
+         Vulcan
+
+ define class <sentient> (<life-form>) end class;
+ define class <bipedal> (<life-form>) end class;
+ define class <intelligent> (<sentient>) end class;
+ define class <humanoid> (<bipedal>) end class;
+ define class <vulcan> (<intelligent>, <humanoid>) end class;
+
+=cut
+
+{
+    package Object;    
+    use mro 'dfs';
+    
+    package LifeForm;
+    use mro 'dfs';
+    use base 'Object';
+    
+    package Sentient;
+    use mro 'dfs';
+    use base 'LifeForm';
+    
+    package BiPedal;
+    use mro 'dfs';    
+    use base 'LifeForm';
+    
+    package Intelligent;
+    use mro 'dfs';    
+    use base 'Sentient';
+    
+    package Humanoid;
+    use mro 'dfs';    
+    use base 'BiPedal';
+    
+    package Vulcan;
+    use mro 'dfs';    
+    use base ('Intelligent', 'Humanoid');
+}
+
+is_deeply(
+    mro::get_linear_isa('Vulcan'),
+    [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal) ],
+    '... got the right MRO for the Vulcan Dylan Example');  
index 294beb0..0ce58d3 100755 (executable)
@@ -440,7 +440,10 @@ ok "@+" eq "10 1 6 10";
 if (!$Is_VMS) {
     local @ISA;
     local %ENV;
-    eval { push @ISA, __PACKAGE__ };
+    # This used to be __PACKAGE__, but that causes recursive
+    #  inheritance, which is detected earlier now and broke
+    #  this test
+    eval { push @ISA, __FILE__ };
     ok( $@ eq '', 'Push a constant on a magic array');
     $@ and print "# $@";
     eval { %ENV = (PATH => __PACKAGE__) };
index d876c6c..d4aa97e 100644 (file)
@@ -36,12 +36,12 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash,
              int len, int level)
 {
     dVAR;
-    AV* av;
-    GV* gv;
-    GV** gvp;
-    HV* hv = NULL;
-    SV* subgen = NULL;
+    AV* stash_linear_isa;
+    SV** svp;
     const char *hvname;
+    I32 items;
+    PERL_UNUSED_ARG(len);
+    PERL_UNUSED_ARG(level);
 
     /* A stash/class can go by many names (ie. User == main::User), so 
        we compare the stash itself just in case */
@@ -56,75 +56,23 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash,
     if (strEQ(name, "UNIVERSAL"))
        return TRUE;
 
-    if (level > 100)
-       Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
-                  hvname);
-
-    gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
-
-    if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (subgen = GvSV(gv))
-       && (hv = GvHV(gv)))
-    {
-       if (SvIV(subgen) == (IV)PL_sub_generation) {
-           SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
-           if (svp) {
-               SV * const sv = *svp;
-#ifdef DEBUGGING
-               if (sv != &PL_sv_undef)
-                   DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
-                                   name, hvname) );
-#endif
-               return (sv == &PL_sv_yes);
-           }
-       }
-       else {
-           DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
-                             hvname) );
-           hv_clear(hv);
-           sv_setiv(subgen, PL_sub_generation);
+    stash_linear_isa = mro_get_linear_isa(stash);
+    svp = AvARRAY(stash_linear_isa) + 1;
+    items = AvFILLp(stash_linear_isa);
+    while (items--) {
+       SV* const basename_sv = *svp++;
+        HV* basestash = gv_stashsv(basename_sv, 0);
+       if (!basestash) {
+           if (ckWARN(WARN_MISC))
+               Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+                           "Can't locate package %"SVf" for the parents of %s",
+                           SVfARG(basename_sv), hvname);
+           continue;
        }
+        if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
+           return TRUE;
     }
 
-    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
-
-    if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
-       if (!hv || !subgen) {
-           gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
-
-           gv = *gvp;
-
-           if (SvTYPE(gv) != SVt_PVGV)
-               gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
-
-           if (!hv)
-               hv = GvHVn(gv);
-           if (!subgen) {
-               subgen = newSViv(PL_sub_generation);
-               GvSV(gv) = subgen;
-           }
-       }
-       if (hv) {
-           SV** svp = AvARRAY(av);
-           /* NOTE: No support for tied ISA */
-           I32 items = AvFILLp(av) + 1;
-           while (items--) {
-               SV* const sv = *svp++;
-               HV* const basestash = gv_stashsv(sv, 0);
-               if (!basestash) {
-                   if (ckWARN(WARN_MISC))
-                       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-                                   "Can't locate package %"SVf" for @%s::ISA",
-                                   SVfARG(sv), hvname);
-                   continue;
-               }
-               if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
-                   (void)hv_store(hv,name,len,&PL_sv_yes,0);
-                   return TRUE;
-               }
-           }
-           (void)hv_store(hv,name,len,&PL_sv_no,0);
-       }
-    }
     return FALSE;
 }
 
index dd41769..ee831e6 100644 (file)
@@ -279,13 +279,13 @@ FULLLIBS2 = $(LIBS2)|$(THRLIBS1)|$(THRLIBS2)
 
 #### End of system configuration section. ####
 
-c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c
+c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mro.c
 c1 = mg.c locale.c mathoms.c miniperlmain.c numeric.c op.c pad.c perl.c perlapi.c perlio.c
 c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_pack.c pp_sort.c pp_sys.c regcomp.c regexec.c reentr.c
 c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c
 c = $(c0) $(c1) $(c2) $(c3)
 
-obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O)
+obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) mro$(O)
 obj1 = globals$(O) gv$(O) hv$(O) locale$(O) mathoms$(O) mg$(O) miniperlmain$(O) numeric$(O) op$(O) pad$(O)
 obj2 = perl$(O) perlapi$(O) perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) reentr$(O)
 obj3 = pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O)
@@ -1619,6 +1619,8 @@ globals$(O) : globals.c $(h)
        $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 gv$(O) : gv.c $(h)
        $(CC) $(CORECFLAGS) $(MMS$SOURCE)
+mro$(O) : mro.c $(h)
+       $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 hv$(O) : hv.c $(h)
        $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 locale$(O) : locale.c $(h)
index e1f15a4..d654fae 100644 (file)
@@ -647,6 +647,7 @@ MICROCORE_SRC       =               \
                ..\dump.c       \
                ..\globals.c    \
                ..\gv.c         \
+               ..\mro.c        \
                ..\hv.c         \
                ..\locale.c     \
                ..\mathoms.c    \
index 4c2bc16..71aa2c1 100644 (file)
@@ -571,6 +571,7 @@ MICROCORE_SRC       =               \
                ..\dump.c       \
                ..\globals.c    \
                ..\gv.c         \
+               ..\mro.c        \
                ..\hv.c         \
                ..\mg.c         \
                ..\op.c         \
@@ -790,6 +791,7 @@ $(DLLDIR)\doop.obj \
 $(DLLDIR)\dump.obj \
 $(DLLDIR)\globals.obj \
 $(DLLDIR)\gv.obj \
+$(DLLDIR)\mro.obj \
 $(DLLDIR)\hv.obj \
 $(DLLDIR)\locale.obj \
 $(DLLDIR)\mathoms.obj \
index 966aa74..d632b16 100644 (file)
@@ -816,6 +816,7 @@ MICROCORE_SRC       =               \
                ..\dump.c       \
                ..\globals.c    \
                ..\gv.c         \
+               ..\mro.c        \
                ..\hv.c         \
                ..\locale.c     \
                ..\mathoms.c    \