+++ /dev/null
-=== Makefile.micro
-==================================================================
---- Makefile.micro (/local/perl-current) (revision 30454)
-+++ Makefile.micro (/local/perl-c3-subg) (revision 30454)
-@@ -10,7 +10,7 @@
- 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 @@
- 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
-
-=== embed.h
-==================================================================
---- embed.h (/local/perl-current) (revision 30454)
-+++ embed.h (/local/perl-c3-subg) (revision 30454)
-@@ -267,6 +267,13 @@
- #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
-+#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
-@@ -2511,6 +2518,13 @@
- #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)
-+#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)
-=== pod/perlapi.pod
-==================================================================
---- pod/perlapi.pod (/local/perl-current) (revision 30454)
-+++ pod/perlapi.pod (/local/perl-c3-subg) (revision 30454)
-@@ -1326,7 +1326,7 @@
- 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
-=== global.sym
-==================================================================
---- global.sym (/local/perl-current) (revision 30454)
-+++ global.sym (/local/perl-c3-subg) (revision 30454)
-@@ -135,6 +135,13 @@
- Perl_gv_efullname4
- Perl_gv_fetchfile
- Perl_gv_fetchfile_flags
-+Perl_mro_meta_init
-+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
-=== perl.c
-==================================================================
---- perl.c (/local/perl-current) (revision 30454)
-+++ perl.c (/local/perl-c3-subg) (revision 30454)
-@@ -2163,6 +2163,7 @@
- boot_core_PerlIO();
- boot_core_UNIVERSAL();
- boot_core_xsutils();
-+ boot_core_mro();
-
- if (xsinit)
- (*xsinit)(aTHX); /* in case linked C routines want magical variables */
-=== universal.c
-==================================================================
---- universal.c (/local/perl-current) (revision 30454)
-+++ universal.c (/local/perl-c3-subg) (revision 30454)
-@@ -36,12 +36,12 @@
- 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 @@
- 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);
-- }
-+ stash_linear_isa = (AV*)sv_2mortal((SV*)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;
- }
-- else {
-- DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
-- hvname) );
-- hv_clear(hv);
-- sv_setiv(subgen, PL_sub_generation);
-- }
-+ 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;
- }
-
-=== scope.c
-==================================================================
---- scope.c (/local/perl-current) (revision 30454)
-+++ scope.c (/local/perl-c3-subg) (revision 30454)
-@@ -256,7 +256,7 @@
- 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 @@
- 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:
-=== gv.c
-==================================================================
---- gv.c (/local/perl-current) (revision 30454)
-+++ gv.c (/local/perl-c3-subg) (revision 30454)
-@@ -260,7 +260,7 @@
- }
- 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 @@
- 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,150 @@
- =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* curstash;
-+ 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);
-+ assert(len >= 0);
-
- 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;
-+ 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;
-+ }
-+ }
-+
-+ 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);
-+ }
- 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 */
-+ linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
- }
-+ sv_2mortal((SV*)linear_av);
-
-- gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
-- av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
-+ 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);
-+ curstash = gv_stashsv(linear_sv, 0);
-
-- /* create and re-create @.*::SUPER::ISA on demand */
-- if (!av || !SvMAGIC(av)) {
-- STRLEN packlen = HvNAMELEN_get(stash);
-+ /* 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 (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
-+ if (ckWARN(WARN_MISC))
-+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
-+ SVfARG(linear_sv), hvname);
-+ continue;
-+ }
-
-- if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
-- HV* basestash;
-+ assert(curstash);
-
-- 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);
-- }
-- }
-+ gvp = (GV**)hv_fetch(curstash, name, len, 0);
-+ if (!gvp) continue;
-+ candidate = *gvp;
-+ assert(candidate);
-+ if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, 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 (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;
-- }
-+ /* 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 at top level, try UNIVERSAL */
--
-- if (level == 0 || level == -1) {
-- lastchance = gv_stashpvs("UNIVERSAL", 0);
--
-- 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;
-@@ -1436,15 +1453,22 @@
- 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;
- }
-@@ -1523,11 +1547,13 @@
- 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);
-@@ -1537,7 +1563,7 @@
-
- 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;
-
-@@ -1649,9 +1675,13 @@
- 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:
-@@ -1661,7 +1691,7 @@
- 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];
-=== lib/constant.pm
-==================================================================
---- lib/constant.pm (/local/perl-current) (revision 30454)
-+++ lib/constant.pm (/local/perl-c3-subg) (revision 30454)
-@@ -5,7 +5,7 @@
- use warnings::register;
-
- our($VERSION, %declared);
--$VERSION = '1.09';
-+$VERSION = '1.10';
-
- #=======================================================================
-
-@@ -109,7 +109,7 @@
- # 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 };
- }
-=== lib/overload.pm
-==================================================================
---- lib/overload.pm (/local/perl-current) (revision 30454)
-+++ lib/overload.pm (/local/perl-c3-subg) (revision 30454)
-@@ -1,6 +1,6 @@
- package overload;
-
--our $VERSION = '1.04';
-+our $VERSION = '1.05';
-
- sub nil {}
-
-@@ -95,12 +95,13 @@
-
- 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;
- }
-
-=== lib/mro.pm
-==================================================================
---- lib/mro.pm (/local/perl-current) (revision 30454)
-+++ lib/mro.pm (/local/perl-c3-subg) (revision 30454)
-@@ -0,0 +1,266 @@
-+# 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;
-+
-+our $VERSION = '0.01';
-+
-+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>).
-+
-+=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_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
-=== win32/Makefile
-==================================================================
---- win32/Makefile (/local/perl-current) (revision 30454)
-+++ win32/Makefile (/local/perl-c3-subg) (revision 30454)
-@@ -647,6 +647,7 @@
- ..\dump.c \
- ..\globals.c \
- ..\gv.c \
-+ ..\mro.c \
- ..\hv.c \
- ..\locale.c \
- ..\mathoms.c \
-=== win32/makefile.mk
-==================================================================
---- win32/makefile.mk (/local/perl-current) (revision 30454)
-+++ win32/makefile.mk (/local/perl-c3-subg) (revision 30454)
-@@ -816,6 +816,7 @@
- ..\dump.c \
- ..\globals.c \
- ..\gv.c \
-+ ..\mro.c \
- ..\hv.c \
- ..\locale.c \
- ..\mathoms.c \
-=== win32/Makefile.ce
-==================================================================
---- win32/Makefile.ce (/local/perl-current) (revision 30454)
-+++ win32/Makefile.ce (/local/perl-c3-subg) (revision 30454)
-@@ -571,6 +571,7 @@
- ..\dump.c \
- ..\globals.c \
- ..\gv.c \
-+ ..\mro.c \
- ..\hv.c \
- ..\mg.c \
- ..\op.c \
-@@ -790,6 +791,7 @@
- $(DLLDIR)\dump.obj \
- $(DLLDIR)\globals.obj \
- $(DLLDIR)\gv.obj \
-+$(DLLDIR)\mro.obj \
- $(DLLDIR)\hv.obj \
- $(DLLDIR)\locale.obj \
- $(DLLDIR)\mathoms.obj \
-=== t/TEST
-==================================================================
---- t/TEST (/local/perl-current) (revision 30454)
-+++ t/TEST (/local/perl-c3-subg) (revision 30454)
-@@ -104,7 +104,7 @@
- }
-
- 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;
-=== t/mro (new directory)
-==================================================================
-=== t/mro/basic_01_dfs.t
-==================================================================
---- t/mro/basic_01_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_01_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/vulcan_c3.t
-==================================================================
---- t/mro/vulcan_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/vulcan_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/basic_02_dfs.t
-==================================================================
---- t/mro/basic_02_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_02_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/next_method.t
-==================================================================
---- t/mro/next_method.t (/local/perl-current) (revision 30454)
-+++ t/mro/next_method.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/basic_03_dfs.t
-==================================================================
---- t/mro/basic_03_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_03_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/next_method_in_anon.t
-==================================================================
---- t/mro/next_method_in_anon.t (/local/perl-current) (revision 30454)
-+++ t/mro/next_method_in_anon.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-+
-+
-=== t/mro/basic_04_dfs.t
-==================================================================
---- t/mro/basic_04_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_04_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-+
-=== t/mro/next_method_edge_cases.t
-==================================================================
---- t/mro/next_method_edge_cases.t (/local/perl-current) (revision 30454)
-+++ t/mro/next_method_edge_cases.t (/local/perl-c3-subg) (revision 30454)
-@@ -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 $@;
-+ }
-+}
-=== t/mro/basic_05_dfs.t
-==================================================================
---- t/mro/basic_05_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_05_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/vulcan_dfs.t
-==================================================================
---- t/mro/vulcan_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/vulcan_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/dbic_c3.t
-==================================================================
---- t/mro/dbic_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/dbic_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/next_method_used_with_NEXT.t
-==================================================================
---- t/mro/next_method_used_with_NEXT.t (/local/perl-current) (revision 30454)
-+++ t/mro/next_method_used_with_NEXT.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-+
-=== t/mro/c3_with_overload.t
-==================================================================
---- t/mro/c3_with_overload.t (/local/perl-current) (revision 30454)
-+++ t/mro/c3_with_overload.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/complex_c3.t
-==================================================================
---- t/mro/complex_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/complex_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/method_caching.t
-==================================================================
---- t/mro/method_caching.t (/local/perl-current) (revision 30454)
-+++ t/mro/method_caching.t (/local/perl-c3-subg) (revision 30454)
-@@ -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);
-=== t/mro/dbic_dfs.t
-==================================================================
---- t/mro/dbic_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/dbic_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/recursion_c3.t
-==================================================================
---- t/mro/recursion_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/recursion_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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???");
-+ }
-+}
-=== t/mro/overload_c3.t
-==================================================================
---- t/mro/overload_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/overload_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-+
-=== t/mro/complex_dfs.t
-==================================================================
---- t/mro/complex_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/complex_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/next_method_skip.t
-==================================================================
---- t/mro/next_method_skip.t (/local/perl-current) (revision 30454)
-+++ t/mro/next_method_skip.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/inconsistent_c3.t
-==================================================================
---- t/mro/inconsistent_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/inconsistent_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/recursion_dfs.t
-==================================================================
---- t/mro/recursion_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/recursion_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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???");
-+ }
-+}
-=== t/mro/basic_01_c3.t
-==================================================================
---- t/mro/basic_01_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_01_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/basic_02_c3.t
-==================================================================
---- t/mro/basic_02_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_02_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/overload_dfs.t
-==================================================================
---- t/mro/overload_dfs.t (/local/perl-current) (revision 30454)
-+++ t/mro/overload_dfs.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-+
-=== t/mro/basic_03_c3.t
-==================================================================
---- t/mro/basic_03_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_03_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/basic_04_c3.t
-==================================================================
---- t/mro/basic_04_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_04_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-+
-=== t/mro/basic_05_c3.t
-==================================================================
---- t/mro/basic_05_c3.t (/local/perl-current) (revision 30454)
-+++ t/mro/basic_05_c3.t (/local/perl-c3-subg) (revision 30454)
-@@ -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');
-=== t/mro/next_method_in_eval.t
-==================================================================
---- t/mro/next_method_in_eval.t (/local/perl-current) (revision 30454)
-+++ t/mro/next_method_in_eval.t (/local/perl-c3-subg) (revision 30454)
-@@ -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{}');
-+
-+
-=== t/op/magic.t
-==================================================================
---- t/op/magic.t (/local/perl-current) (revision 30454)
-+++ t/op/magic.t (/local/perl-c3-subg) (revision 30454)
-@@ -440,7 +440,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__) };
-=== NetWare/Makefile
-==================================================================
---- NetWare/Makefile (/local/perl-current) (revision 30454)
-+++ NetWare/Makefile (/local/perl-c3-subg) (revision 30454)
-@@ -701,6 +701,7 @@
- ..\dump.c \
- ..\globals.c \
- ..\gv.c \
-+ ..\mro.c \
- ..\hv.c \
- ..\locale.c \
- ..\mathoms.c \
-=== vms/descrip_mms.template
-==================================================================
---- vms/descrip_mms.template (/local/perl-current) (revision 30454)
-+++ vms/descrip_mms.template (/local/perl-c3-subg) (revision 30454)
-@@ -279,13 +279,13 @@
-
- #### 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 @@
- $(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)
-=== Makefile.SH
-==================================================================
---- Makefile.SH (/local/perl-current) (revision 30454)
-+++ Makefile.SH (/local/perl-c3-subg) (revision 30454)
-@@ -367,7 +367,7 @@
- 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 @@
-
- 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)
-
-=== proto.h
-==================================================================
---- proto.h (/local/perl-current) (revision 30454)
-+++ proto.h (/local/perl-c3-subg) (revision 30454)
-@@ -635,6 +635,25 @@
- 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);
-+
-+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);
-
-=== ext/B/t/b.t
-==================================================================
---- ext/B/t/b.t (/local/perl-current) (revision 30454)
-+++ ext/B/t/b.t (/local/perl-c3-subg) (revision 30454)
-@@ -169,7 +169,7 @@
- {
- no warnings 'once';
- my $sg = B::sub_generation();
-- *Whatever::hand_waving = sub { };
-+ *UNIVERSAL::hand_waving = sub { };
- ok( $sg < B::sub_generation, "sub_generation increments" );
- }
-
-=== MANIFEST
-==================================================================
---- MANIFEST (/local/perl-current) (revision 30454)
-+++ MANIFEST (/local/perl-c3-subg) (revision 30454)
-@@ -2252,6 +2252,7 @@
- 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
-@@ -2953,6 +2954,7 @@
- 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
-@@ -3619,6 +3621,35 @@
- 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/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/next_method.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_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
-+t/mro/method_caching.t mro tests
- Todo.micro The Wishlist for microperl
- toke.c The tokener
- t/op/64bitint.t See if 64 bit integers work
-=== mro.c
-==================================================================
---- mro.c (/local/perl-current) (revision 30454)
-+++ mro.c (/local/perl-c3-subg) (revision 30454)
-@@ -0,0 +1,901 @@
-+/* 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;
-+}
-+
-+/*
-+=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 */
-+ SvREFCNT_inc_simple_void_NN(retval);
-+ return retval;
-+ }
-+
-+ /* not in cache, make a new one */
-+ retval = (AV*)sv_2mortal((SV*)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 = (AV*)sv_2mortal((SV*)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);
-+ SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
-+ SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
-+ 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 */
-+ SvREFCNT_inc_simple_void_NN(retval);
-+ return retval;
-+ }
-+
-+ /* not in cache, make a new one */
-+
-+ retval = (AV*)sv_2mortal((SV*)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 = (AV*)sv_2mortal((SV*)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)
-+ Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
-+ "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
-+ }
-+ }
-+
-+ SvREADONLY_on(retval);
-+ SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
-+ SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
-+ 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);
-+ sv_2mortal((SV*)meta->mro_linear_dfs);
-+ sv_2mortal((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);
-+
-+ /* Recalcs whichever of the above two cleared linearizations
-+ are in effect and gives it to us */
-+ linear_mro = mro_get_linear_isa(stash);
-+ isarev = meta->mro_isarev;
-+
-+ /* Iterate the isarev (classes that are our children),
-+ wiping out their linearization and method caches */
-+ if(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);
-+ sv_2mortal((SV*)revmeta->mro_linear_dfs);
-+ sv_2mortal((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 */
-+ 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)
-+ croak("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)
-+ croak("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)
-+ croak("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)
-+ croak("No next::method '%s' found for %s", subname, hvname);
-+ return &PL_sv_undef;
-+ }
-+ return SvREFCNT_inc_simple_NN(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 */
-+ sv_2mortal((SV*)linear_av);
-+
-+ 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)
-+ croak("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_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_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;
-+
-+ if(items < 1 || items > 2)
-+ croak("Usage: mro::get_linear_isa(classname [, type ])");
-+
-+ classname = ST(0);
-+ class_stash = gv_stashsv(classname, 0);
-+ if(!class_stash) croak("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
-+ croak("Invalid mro name: '%s'", which);
-+ }
-+ else {
-+ RETVAL = mro_get_linear_isa(class_stash);
-+ }
-+
-+ ST(0) = newRV_noinc((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;
-+
-+ if (items != 2)
-+ croak("Usage: mro::set_mro(classname, type)");
-+
-+ classname = ST(0);
-+ whichstr = SvPV_nolen(ST(1));
-+ class_stash = gv_stashsv(classname, GV_ADD);
-+ if(!class_stash) croak("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
-+ croak("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;
-+
-+ if (items != 1)
-+ croak("Usage: mro::get_mro(classname)");
-+
-+ classname = ST(0);
-+ class_stash = gv_stashsv(classname, 0);
-+ if(!class_stash) croak("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_global_sub_generation)
-+{
-+ dVAR;
-+ dXSARGS;
-+
-+ if (items != 0)
-+ croak("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;
-+
-+ if (items != 0)
-+ croak("Usage: mro::invalidate_all_method_caches()");
-+
-+ PL_sub_generation++;
-+
-+ XSRETURN_EMPTY;
-+}
-+
-+XS(XS_mro_get_sub_generation)
-+{
-+ dVAR;
-+ dXSARGS;
-+ SV* classname;
-+ HV* class_stash;
-+
-+ if(items != 1)
-+ croak("Usage: mro::get_sub_generation(classname)");
-+
-+ classname = ST(0);
-+ class_stash = gv_stashsv(classname, 0);
-+ if(!class_stash) croak("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;
-+
-+ if(items != 1)
-+ croak("Usage: mro::method_changed_in(classname)");
-+
-+ classname = ST(0);
-+
-+ class_stash = gv_stashsv(classname, 0);
-+ if(!class_stash) croak("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(self, 0);
-+
-+ 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(self, 1);
-+
-+ PL_markstack_ptr++;
-+ call_sv(methcv, GIMME_V);
-+}
-+
-+XS(XS_maybe_next_method)
-+{
-+ dMARK;
-+ dAX;
-+ SV* self = ST(0);
-+ SV* methcv = __nextcan(self, 0);
-+
-+ 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:
-+ */
-=== hv.c
-==================================================================
---- hv.c (/local/perl-current) (revision 30454)
-+++ hv.c (/local/perl-c3-subg) (revision 30454)
-@@ -1531,7 +1531,7 @@
- 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 @@
-
- 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 @@
- 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 @@
- iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
- iter->xhv_name = 0;
- iter->xhv_backreferences = 0;
-+ iter->xhv_mro_meta = NULL;
- return iter;
- }
-
-=== hv.h
-==================================================================
---- hv.h (/local/perl-current) (revision 30454)
-+++ hv.h (/local/perl-c3-subg) (revision 30454)
-@@ -38,12 +38,38 @@
-
- /* 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 @@
- #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. */
-=== mg.c
-==================================================================
---- mg.c (/local/perl-current) (revision 30454)
-+++ mg.c (/local/perl-c3-subg) (revision 30454)
-@@ -1530,8 +1530,18 @@
- {
- 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 @@
- dVAR;
- PERL_UNUSED_ARG(sv);
- PERL_UNUSED_ARG(mg);
-- /* HV_badAMAGIC_on(Sv_STASH(sv)); */
- PL_amagic_generation++;
-
- return 0;
-=== op.c
-==================================================================
---- op.c (/local/perl-current) (revision 30454)
-+++ op.c (/local/perl-c3-subg) (revision 30454)
-@@ -3649,6 +3649,11 @@
- 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 @@
- 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 @@
- 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 @@
- }
- }
- GvCVGEN(gv) = 0;
-- PL_sub_generation++;
-+ mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
- }
- }
- CvGV(cv) = gv;
-@@ -5802,7 +5813,7 @@
- if (name) {
- GvCV(gv) = cv;
- GvCVGEN(gv) = 0;
-- PL_sub_generation++;
-+ mro_method_changed_in(GvSTASH(gv)); /* newXS */
- }
- }
- CvGV(cv) = gv;
-=== sv.c
-==================================================================
---- sv.c (/local/perl-current) (revision 30454)
-+++ sv.c (/local/perl-c3-subg) (revision 30454)
-@@ -3245,7 +3245,7 @@
- SvREFCNT_dec(GvCV(dstr));
- GvCV(dstr) = NULL;
- GvCVGEN(dstr) = 0; /* Switch off cacheness. */
-- PL_sub_generation++;
-+ mro_method_changed_in(GvSTASH(dstr));
- }
- }
- SAVEGENERICSV(*location);
-@@ -3291,7 +3291,7 @@
- }
- 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)
-=== pp_hot.c
-==================================================================
---- pp_hot.c (/local/perl-current) (revision 30454)
-+++ pp_hot.c (/local/perl-c3-subg) (revision 30454)
-@@ -192,7 +192,7 @@
-
- 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 @@
- 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);
- }
- }
-=== embed.fnc
-==================================================================
---- embed.fnc (/local/perl-current) (revision 30454)
-+++ embed.fnc (/local/perl-c3-subg) (revision 30454)
-@@ -282,6 +282,13 @@
- 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
-+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
-
-Property changes on:
-___________________________________________________________________
-Name: svk:merge
- +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3:30450
- +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3-isarev:29720
- +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-current:30449
-
projects / gitmo/Class-C3.git / commitdiff