From: Brandon L Black Date: Tue, 17 Apr 2007 16:04:41 +0000 (+0000) Subject: replace patch with link X-Git-Tag: 0.16~1^2~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FClass-C3.git;a=commitdiff_plain;h=ff5d5837313d7af9df1f3892e1340fe094beced5 replace patch with link --- diff --git a/ChangeLog b/ChangeLog index 7f30825..d859e5b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,11 @@ Revision history for Perl extension Class::C3. + - Patch not included directly anymore + +0.15_03 Tue, Apr 17, 2007 + - New c3.patch, improves threads compat and + mem mgmt. + 0.15_02 Sun, Apr 15, 2007 - Fix for overloading to method name string, from Ittetsu Miyazaki. diff --git a/README b/README index d0992d3..06477db 100644 --- a/README +++ b/README @@ -20,20 +20,24 @@ This module requires these other modules and libraries: Additionally, this module will optionally take advantage of these if installed: - Class::C3::XS 0.01_01 + Class::C3::XS 0.01_06 -SPECIAL NOTE FOR 0.15_01 +SPECIAL NOTE FOR 0.15_04 To try this with the experimental perl core c3 patch, -download a recent copy perl-current: +download the most recent copy perl-current: -http://mirrors.develooper.com/perl/APC/perl-current-snap/perl-current@30943.tar.bz2 +http://mirrors.develooper.com/perl/APC/perl-current-snap/ -apply the enclosed c3.patch, and install this perl: +Apply the latest C3 patch from: + +http://www.dtmf.com/c3-subgen.patch + +Then: sh Configure -Dusedevel -Dprefix=/where/I/want/it -d -e && make && make test && make install -then try your C3-using software against this perl + Class::C3 0.15_01. +then try your C3-using software against this perl + Class::C3 0.15_04. COPYRIGHT AND LICENCE diff --git a/c3.patch b/c3.patch deleted file mode 100644 index 14ecf7d..0000000 --- a/c3.patch +++ /dev/null @@ -1,4701 +0,0 @@ -=== 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 should be either 0 or -1. If C, as a - side-effect creates a glob with the given C in the given C - 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 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 should be either 0 or -1. If C, as a - side-effect creates a glob with the given C in the given C - 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 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 -+as shown in the synopsis, or by using the L -+function below. The functions below do not require that one -+loads the "mro" module, they are provided by the core. The -+C 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 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, 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 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: -+ -+ -+ / \ -+ -+ \ / -+ -+ -+The standard Perl 5 MRO would be (D, B, A, C). The result being that B appears before B, even though B is the subclass of B. 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 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 or C if specified as C). -+ -+=head2 mro::set_mro -+ -+Arguments: classname, type -+ -+Sets the MRO of the given class to the C argument (either -+C or C). -+ -+=head2 mro::get_mro -+ -+Arguments: classname -+ -+Returns the MRO of the given class (either C or C) -+ -+=head2 mro::get_global_sub_generation -+ -+Arguments: none -+ -+Returns the current value of C. -+ -+=head2 mro::invalidate_all_method_caches -+ -+Arguments: none -+ -+Increments C, which invalidates method -+caching in all packages. -+ -+=head2 mro::get_sub_generation -+ -+Arguments: classname -+ -+Returns the current value of a given package's C. -+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, 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 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 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 from methods defined outside the class: -+ -+There is an edge case when using C 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 as you might expect. Since C uses C 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 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, but just returns either -+a code reference or C 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 -+ -+=back -+ -+=head2 The prototype Perl 6 Object Model uses C3 -+ -+=over 4 -+ -+=item L -+ -+=back -+ -+=head2 Parrot now uses C3 -+ -+=over 4 -+ -+=item L -+ -+=item L -+ -+=back -+ -+=head2 Python 2.3 MRO related links -+ -+=over 4 -+ -+=item L -+ -+=item L -+ -+=back -+ -+=head2 C3 for TinyCLOS -+ -+=over 4 -+ -+=item L -+ -+=back -+ -+=head2 Class::C3 -+ -+=over 4 -+ -+=item L -+ -+=back -+ -+=head1 AUTHOR -+ -+Brandon L. Black, Eblblack@gmail.comE -+ -+Based on Stevan Little's L -+ -+=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. -+ -+ -+ / \ -+ -+ \ / -+ -+ -+=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 -+ -+ Object -+ ^ -+ | -+ LifeForm -+ ^ ^ -+ / \ -+ Sentient BiPedal -+ ^ ^ -+ | | -+ Intelligent Humanoid -+ ^ ^ -+ \ / -+ Vulcan -+ -+ define class () end class; -+ define class () end class; -+ define class () end class; -+ define class () end class; -+ define class (, ) 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. -+ -+ -+ / \ -+ -+ \ / -+ -+ -+=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() -+(, , , -+, , , -+) -+ -+=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!!!! -+ -+ -+ / \ -+ -+ \ / -+ -+ -+=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 -+ -+ Object -+ ^ -+ | -+ LifeForm -+ ^ ^ -+ / \ -+ Sentient BiPedal -+ ^ ^ -+ | | -+ Intelligent Humanoid -+ ^ ^ -+ \ / -+ Vulcan -+ -+ define class () end class; -+ define class () end class; -+ define class () end class; -+ define class () end class; -+ define class (, ) 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. -+ -+ -+ / \ -+ -+ \ / -+ -+ -+=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. -+ -+ -+ / \ -+ -+ \ / -+ -+ -+=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() -+(, , , -+, , , -+) -+ -+=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!!!! -+ -+ -+ / \ -+ -+ \ / -+ -+ -+=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 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 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 or -+C 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 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, 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 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, 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 - diff --git a/lib/Class/C3.pm b/lib/Class/C3.pm index 3fb7b29..793c182 100644 --- a/lib/Class/C3.pm +++ b/lib/Class/C3.pm @@ -4,7 +4,7 @@ package Class::C3; use strict; use warnings; -our $VERSION = '0.15_02'; +our $VERSION = '0.15_04'; our $C3_IN_CORE; our $C3_XS; @@ -253,18 +253,22 @@ Class::C3 - A pragma to use the C3 method resolution order algortihm D->can('hello')->(); # can() also works correctly UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can() -=head1 SPECIAL NOTE FOR 0.15_01 +=head1 SPECIAL NOTE FOR 0.15_04 To try this with the experimental perl core c3 patch, -download a recent copy perl-current: +download the most recent copy perl-current: -http://mirrors.develooper.com/perl/APC/perl-current-snap/perl-current@30943.tar.bz2 +http://mirrors.develooper.com/perl/APC/perl-current-snap/ -apply the enclosed c3.patch, and install this perl: +Apply the latest C3 patch from: + +http://www.dtmf.com/c3-subgen.patch + +Then: sh Configure -Dusedevel -Dprefix=/where/I/want/it -d -e && make && make test && make install -then try your C3-using software against this perl + Class::C3 0.15_01. +then try your C3-using software against this perl + Class::C3 0.15_04. =head1 DESCRIPTION