@@ -0,0 +1,4701 @@
+=== 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
+