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
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
t/lib/warnings/universal Tests for universal.c for warnings.t
t/lib/warnings/utf8 Tests for utf8.c for warnings.t
t/lib/warnings/util Tests for util.c for warnings.t
+t/mro/basic_01_c3.t mro tests
+t/mro/basic_01_dfs.t mro tests
+t/mro/basic_02_c3.t mro tests
+t/mro/basic_02_dfs.t mro tests
+t/mro/basic_03_c3.t mro tests
+t/mro/basic_03_dfs.t mro tests
+t/mro/basic_04_c3.t mro tests
+t/mro/basic_04_dfs.t mro tests
+t/mro/basic_05_c3.t mro tests
+t/mro/basic_05_dfs.t mro tests
+t/mro/basic.t mro tests
+t/mro/c3_with_overload.t mro tests
+t/mro/complex_c3.t mro tests
+t/mro/complex_dfs.t mro tests
+t/mro/dbic_c3.t mro tests
+t/mro/dbic_dfs.t mro tests
+t/mro/inconsistent_c3.t mro tests
+t/mro/method_caching.t mro tests
+t/mro/next_method_edge_cases.t mro tests
+t/mro/next_method_in_anon.t mro tests
+t/mro/next_method_in_eval.t mro tests
+t/mro/next_method_skip.t mro tests
+t/mro/next_method.t mro tests
+t/mro/next_method_used_with_NEXT.t mro tests
+t/mro/overload_c3.t mro tests
+t/mro/overload_dfs.t mro tests
+t/mro/recursion_c3.t mro tests
+t/mro/recursion_dfs.t mro tests
+t/mro/vulcan_c3.t mro tests
+t/mro/vulcan_dfs.t mro tests
Todo.micro The Wishlist for microperl
toke.c The tokener
t/op/64bitint.t See if 64 bit integers work
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
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)
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) \
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
..\dump.c \
..\globals.c \
..\gv.c \
+ ..\mro.c \
..\hv.c \
..\locale.c \
..\mathoms.c \
Ap |GV* |gv_fetchfile |NN const char* name
Ap |GV* |gv_fetchfile_flags|NN const char *const name|const STRLEN len\
|const U32 flags
+ApM |struct mro_meta* |mro_meta_init |NN HV* stash
+#if defined(USE_ITHREADS)
+ApM |struct mro_meta* |mro_meta_dup |NN struct mro_meta* smeta|NN CLONE_PARAMS* param
+#endif
+ApM |AV* |mro_get_linear_isa|NN HV* stash
+ApM |AV* |mro_get_linear_isa_c3|NN HV* stash|I32 level
+ApM |AV* |mro_get_linear_isa_dfs|NN HV* stash|I32 level
+ApM |void |mro_isa_changed_in|NN HV* stash
+ApM |void |mro_method_changed_in |NN HV* stash
+ApM |void |boot_core_mro
Apd |GV* |gv_fetchmeth |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
Apd |GV* |gv_fetchmeth_autoload |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
Apdmb |GV* |gv_fetchmethod |NULLOK HV* stash|NN const char* name
#define gv_efullname4 Perl_gv_efullname4
#define gv_fetchfile Perl_gv_fetchfile
#define gv_fetchfile_flags Perl_gv_fetchfile_flags
+#define mro_meta_init Perl_mro_meta_init
+#if defined(USE_ITHREADS)
+#define mro_meta_dup Perl_mro_meta_dup
+#endif
+#define mro_get_linear_isa Perl_mro_get_linear_isa
+#define mro_get_linear_isa_c3 Perl_mro_get_linear_isa_c3
+#define mro_get_linear_isa_dfs Perl_mro_get_linear_isa_dfs
+#define mro_isa_changed_in Perl_mro_isa_changed_in
+#define mro_method_changed_in Perl_mro_method_changed_in
+#define boot_core_mro Perl_boot_core_mro
#define gv_fetchmeth Perl_gv_fetchmeth
#define gv_fetchmeth_autoload Perl_gv_fetchmeth_autoload
#define gv_fetchmethod_autoload Perl_gv_fetchmethod_autoload
#define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d)
#define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a)
#define gv_fetchfile_flags(a,b,c) Perl_gv_fetchfile_flags(aTHX_ a,b,c)
+#define mro_meta_init(a) Perl_mro_meta_init(aTHX_ a)
+#if defined(USE_ITHREADS)
+#define mro_meta_dup(a,b) Perl_mro_meta_dup(aTHX_ a,b)
+#endif
+#define mro_get_linear_isa(a) Perl_mro_get_linear_isa(aTHX_ a)
+#define mro_get_linear_isa_c3(a,b) Perl_mro_get_linear_isa_c3(aTHX_ a,b)
+#define mro_get_linear_isa_dfs(a,b) Perl_mro_get_linear_isa_dfs(aTHX_ a,b)
+#define mro_isa_changed_in(a) Perl_mro_isa_changed_in(aTHX_ a)
+#define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a)
+#define boot_core_mro() Perl_boot_core_mro(aTHX)
#define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d)
#define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
#define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
{
no warnings 'once';
my $sg = B::sub_generation();
- *Whatever::hand_waving = sub { };
+ *UNIVERSAL::hand_waving = sub { };
ok( $sg < B::sub_generation, "sub_generation increments" );
}
Perl_gv_efullname4
Perl_gv_fetchfile
Perl_gv_fetchfile_flags
+Perl_mro_meta_init
+Perl_mro_meta_dup
+Perl_mro_get_linear_isa
+Perl_mro_get_linear_isa_c3
+Perl_mro_get_linear_isa_dfs
+Perl_mro_isa_changed_in
+Perl_mro_method_changed_in
+Perl_boot_core_mro
Perl_gv_fetchmeth
Perl_gv_fetchmeth_autoload
Perl_gv_fetchmethod
}
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;
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
which in the case of success contains an alias for the subroutine, and sets
-up caching info for this glob. Similarly for all the searched stashes.
+up caching info for this glob.
This function grants C<"SUPER"> token as a postfix of the stash name. The
GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
=cut
*/
+/* NOTE: No support for tied ISA */
+
GV *
Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
dVAR;
- AV* av;
- GV* topgv;
- GV* gv;
GV** gvp;
- CV* cv;
+ AV* linear_av;
+ SV** linear_svp;
+ SV* linear_sv;
+ HV* cstash;
+ GV* candidate = NULL;
+ CV* cand_cv = NULL;
+ CV* old_cv;
+ GV* topgv = NULL;
const char *hvname;
- HV* lastchance = NULL;
+ I32 create = (level >= 0) ? 1 : 0;
+ I32 items;
+ STRLEN packlen;
+ U32 topgen_cmp;
/* UNIVERSAL methods should be callable without a stash */
if (!stash) {
- level = -1; /* probably appropriate */
+ create = 0; /* probably appropriate */
if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
return 0;
}
+ assert(stash);
+
hvname = HvNAME_get(stash);
if (!hvname)
- Perl_croak(aTHX_
- "Can't use anonymous symbol table for method lookup");
+ Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
- if ((level > 100) || (level < -100))
- Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
- name, hvname);
+ assert(hvname);
+ assert(name);
DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
- gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
- if (!gvp)
- topgv = NULL;
- else {
- topgv = *gvp;
- if (SvTYPE(topgv) != SVt_PVGV)
- gv_init(topgv, stash, name, len, TRUE);
- if ((cv = GvCV(topgv))) {
- /* If genuine method or valid cache entry, use it */
- if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
- return topgv;
- /* Stale cached entry: junk it */
- SvREFCNT_dec(cv);
- GvCV(topgv) = cv = NULL;
- GvCVGEN(topgv) = 0;
- }
- else if (GvCVGEN(topgv) == PL_sub_generation)
- return 0; /* cache indicates sub doesn't exist */
+ topgen_cmp = HvMROMETA(stash)->sub_generation + PL_sub_generation;
+
+ /* check locally for a real method or a cache entry */
+ gvp = (GV**)hv_fetch(stash, name, len, create);
+ if(gvp) {
+ topgv = *gvp;
+ assert(topgv);
+ if (SvTYPE(topgv) != SVt_PVGV)
+ gv_init(topgv, stash, name, len, TRUE);
+ if ((cand_cv = GvCV(topgv))) {
+ /* If genuine method or valid cache entry, use it */
+ if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
+ return topgv;
+ }
+ else {
+ /* stale cache entry, junk it and move on */
+ SvREFCNT_dec(cand_cv);
+ GvCV(topgv) = cand_cv = NULL;
+ GvCVGEN(topgv) = 0;
+ }
+ }
+ else if (GvCVGEN(topgv) == topgen_cmp) {
+ /* cache indicates no such method definitively */
+ return 0;
+ }
}
- gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
- av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
-
- /* create and re-create @.*::SUPER::ISA on demand */
- if (!av || !SvMAGIC(av)) {
- STRLEN packlen = HvNAMELEN_get(stash);
-
- if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
- HV* basestash;
-
- packlen -= 7;
- basestash = gv_stashpvn(hvname, packlen, GV_ADD);
- gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
- if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
- gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
- if (!gvp || !(gv = *gvp))
- Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
- if (SvTYPE(gv) != SVt_PVGV)
- gv_init(gv, stash, "ISA", 3, TRUE);
- SvREFCNT_dec(GvAV(gv));
- GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
- }
- }
+ packlen = HvNAMELEN_get(stash);
+ if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
+ HV* basestash;
+ packlen -= 7;
+ basestash = gv_stashpvn(hvname, packlen, GV_ADD);
+ linear_av = mro_get_linear_isa(basestash);
}
-
- if (av) {
- SV** svp = AvARRAY(av);
- /* NOTE: No support for tied ISA */
- I32 items = AvFILLp(av) + 1;
- while (items--) {
- SV* const sv = *svp++;
- HV* const basestash = gv_stashsv(sv, 0);
- if (!basestash) {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
- SVfARG(sv), hvname);
- continue;
- }
- gv = gv_fetchmeth(basestash, name, len,
- (level >= 0) ? level + 1 : level - 1);
- if (gv)
- goto gotcha;
- }
+ else {
+ linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
}
- /* if at top level, try UNIVERSAL */
+ linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
+ items = AvFILLp(linear_av); /* no +1, to skip over self */
+ while (items--) {
+ linear_sv = *linear_svp++;
+ assert(linear_sv);
+ cstash = gv_stashsv(linear_sv, 0);
+
+ /* mg.c:Perl_magic_setisa sets the fake flag on packages it had
+ to create that the user did not. The "package" statement
+ clears it. We also check if there's anything in the symbol
+ table at all, which would indicate a previously "fake" package
+ where someone adding things via $Foo::Bar = 1 without ever
+ using a "package" statement.
+ This was all neccesary because magic_setisa needs a place to
+ keep isarev information on packages that aren't yet defined,
+ yet we still need to issue this warning when appropriate.
+ */
+ if (!cstash || (HvMROMETA(cstash)->fake && !HvFILL(cstash))) {
+ if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
+ SVfARG(linear_sv), hvname);
+ continue;
+ }
+
+ assert(cstash);
+
+ gvp = (GV**)hv_fetch(cstash, name, len, 0);
+ if (!gvp) continue;
+ candidate = *gvp;
+ assert(candidate);
+ if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
+ if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
+ /*
+ * Found real method, cache method in topgv if:
+ * 1. topgv has no synonyms (else inheritance crosses wires)
+ * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
+ */
+ if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
+ if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
+ SvREFCNT_inc_simple_void_NN(cand_cv);
+ GvCV(topgv) = cand_cv;
+ GvCVGEN(topgv) = topgen_cmp;
+ }
+ return candidate;
+ }
+ }
- if (level == 0 || level == -1) {
- lastchance = gv_stashpvs("UNIVERSAL", 0);
+ /* Check UNIVERSAL without caching */
+ if(level == 0 || level == -1) {
+ candidate = gv_fetchmeth(NULL, name, len, 1);
+ if(candidate) {
+ cand_cv = GvCV(candidate);
+ if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
+ if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
+ SvREFCNT_inc_simple_void_NN(cand_cv);
+ GvCV(topgv) = cand_cv;
+ GvCVGEN(topgv) = topgen_cmp;
+ }
+ return candidate;
+ }
+ }
- if (lastchance) {
- if ((gv = gv_fetchmeth(lastchance, name, len,
- (level >= 0) ? level + 1 : level - 1)))
- {
- gotcha:
- /*
- * Cache method in topgv if:
- * 1. topgv has no synonyms (else inheritance crosses wires)
- * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
- */
- if (topgv &&
- GvREFCNT(topgv) == 1 &&
- (cv = GvCV(gv)) &&
- (CvROOT(cv) || CvXSUB(cv)))
- {
- if ((cv = GvCV(topgv)))
- SvREFCNT_dec(cv);
- GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
- GvCVGEN(topgv) = PL_sub_generation;
- }
- return gv;
- }
- else if (topgv && GvREFCNT(topgv) == 1) {
- /* cache the fact that the method is not defined */
- GvCVGEN(topgv) = PL_sub_generation;
- }
- }
+ if (topgv && GvREFCNT(topgv) == 1) {
+ /* cache the fact that the method is not defined */
+ GvCVGEN(topgv) = topgen_cmp;
}
return 0;
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;
}
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);
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;
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:
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];
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));
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
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. */
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
iter->xhv_name = 0;
iter->xhv_backreferences = 0;
+ iter->xhv_mro_meta = NULL;
return iter;
}
/* 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: */
#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. */
use warnings::register;
our($VERSION, %declared);
-$VERSION = '1.09';
+$VERSION = '1.10';
#=======================================================================
# 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 };
}
--- /dev/null
+# mro.pm
+#
+# Copyright (c) 2007 Brandon L Black
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package mro;
+use strict;
+use warnings;
+
+# mro.pm versions < 1.00 reserved for possible CPAN mro dist
+# (for partial back-compat to 5.[68].x)
+our $VERSION = '1.00';
+
+sub import {
+ mro::set_mro(scalar(caller), $_[1]) if $_[1];
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+mro - Method Resolution Order
+
+=head1 SYNOPSIS
+
+ use mro 'dfs'; # enable DFS mro for this class (Perl default)
+ use mro 'c3'; # enable C3 mro for this class
+
+=head1 DESCRIPTION
+
+The "mro" namespace provides several utilities for dealing
+with method resolution order and method caching in general.
+
+=head1 OVERVIEW
+
+One can change the mro of a given class by either C<use mro>
+as shown in the synopsis, or by using the L</mro::set_mro>
+function below. The functions below do not require that one
+loads the "mro" module, they are provided by the core. The
+C<use mro> syntax is just syntax sugar for setting the current
+package's mro.
+
+=head1 The C3 MRO
+
+In addition to the traditional Perl default MRO (depth first
+search, called C<dfs> here), Perl now offers the C3 MRO as
+well. Perl's support for C3 is based on the work done in
+Stevan Little's L<Class::C3>, and most of the C3-related
+documentation here is ripped directly from there.
+
+=head2 What is C3?
+
+C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
+inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
+and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in
+Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
+default MRO for Parrot objects as well.
+
+=head2 How does C3 work.
+
+C3 works by always preserving local precendence ordering. This essentially means that no class will appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:
+
+ <A>
+ / \
+ <B> <C>
+ \ /
+ <D>
+
+The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO (D, B, C, A), which does not have this same issue.
+
+This example is fairly trival, for more complex examples and a deeper explaination, see the links in the L<SEE ALSO - C3 Links> section.
+
+=head1 Functions
+
+=head2 mro::get_linear_isa
+
+Arguments: classname[, type]
+
+Return an arrayref which is the linearized MRO of the given class.
+Uses whichever MRO is currently in effect for that class by default,
+or the given mro (either C<c3> or C<dfs> if specified as C<type>).
+
+C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not part
+of the MRO of a class, even though all classes implicitly inherit
+methods from C<UNIVERSAL> and its parents.
+
+=head2 mro::set_mro
+
+Arguments: classname, type
+
+Sets the MRO of the given class to the C<type> argument (either
+C<c3> or C<dfs>).
+
+=head2 mro::get_mro
+
+Arguments: classname
+
+Returns the MRO of the given class (either C<c3> or C<dfs>)
+
+=head2 mro::get_isarev
+
+Arguments: classname
+
+Gets the C<mro_isarev> for this class, returned as an
+array of classnames. These are every class that "isa"
+the given classname, even if the isa relationship is
+indirect. This is used internally by the mro code to
+keep track of method/mro cache invalidations.
+
+Currently, this list only grows, it never shrinks. This
+was a performance consideration (properly tracking and
+deleting isarev entries when someone removes an entry
+from an C<@ISA> is costly, and it doesn't happen often
+anyways). The fact that a class which no longer truly
+"isa" this class at runtime remains on the list should be
+considered a quirky implementation detail which is subject
+to future change. It shouldn't be an issue as long as
+you're looking at this list for the same reasons the
+core code does: as a performance optimization
+over having to search every class in existence.
+
+As with C<mro::get_mro> above, C<UNIVERSAL> is special.
+C<UNIVERSAL> (and parents') isarev lists do not include
+every class in existence, even though all classes are
+effectively descendants for method inheritance purposes.
+
+=head2 mro::is_universal
+
+Arguments: classname
+
+Returns a boolean status indicating whether or not
+the given classname is either C<UNIVERSAL> itself,
+or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
+
+Any class for which this function returns true is
+"universal" in the sense that all classes potentially
+inherit methods from it.
+
+For similar reasons to C<isarev> above, this flag is
+permanent. Once it is set, it does not go away, even
+if the class in question really isn't universal anymore.
+
+=head2 mro::get_global_sub_generation
+
+Arguments: none
+
+Returns the current value of C<PL_sub_generation>.
+
+=head2 mro::invalidate_all_method_caches
+
+Arguments: none
+
+Increments C<PL_sub_generation>, which invalidates method
+caching in all packages.
+
+=head2 mro::get_sub_generation
+
+Arguments: classname
+
+Returns the current value of a given package's C<sub_generation>.
+This is only incremented when necessary for that package.
+
+If one is trying to determine whether significant (method/cache-
+affecting) changes have occured for a given stash since you last
+checked, you should check both this and the global one above.
+
+=head2 mro::method_changed_in
+
+Arguments: classname
+
+Invalidates the method cache of any classes dependant on the
+given class.
+
+=head2 next::method
+
+This is somewhat like C<SUPER>, but it uses the C3 method
+resolution order to get better consistency in multiple
+inheritance situations. Note that while inheritance in
+general follows whichever MRO is in effect for the
+given class, C<next::method> only uses the C3 MRO.
+
+One generally uses it like so:
+
+ sub some_method {
+ my $self = shift;
+
+ my $superclass_answer = $self->next::method(@_);
+ return $superclass_answer + 1;
+ }
+
+Note that you don't (re-)specify the method name.
+It forces you to always use the same method name
+as the method you started in.
+
+It can be called on an object or a class, of course.
+
+The way it resolves which actual method to call is:
+
+1) First, it determines the linearized C3 MRO of
+the object or class it is being called on.
+
+2) Then, it determines the class and method name
+of the context it was invoked from.
+
+3) Finally, it searches down the C3 MRO list until
+it reaches the contextually enclosing class, then
+searches further down the MRO list for the next
+method with the same name as the contextually
+enclosing method.
+
+Failure to find a next method will result in an
+exception being thrown (see below for alternatives).
+
+This is substantially different than the behavior
+of C<SUPER> under complex multiple inheritance,
+(this becomes obvious when one realizes that the
+common superclasses in the C3 linearizations of
+a given class and one of its parents will not
+always be ordered the same for both).
+
+Caveat - Calling C<next::method> from methods defined outside the class:
+
+There is an edge case when using C<next::method> from within a subroutine which was created in a different module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which will not work correctly:
+
+ *Foo::foo = sub { (shift)->next::method(@_) };
+
+The problem exists because the anonymous subroutine being assigned to the glob C<*Foo::foo> will show up in the call stack as being called C<__ANON__> and not C<foo> as you might expect. Since C<next::method> uses C<caller> to find the name of the method it was called in, it will fail in this case.
+
+But fear not, there is a simple solution. The module C<Sub::Name> will reach into the perl internals and assign a name to an anonymous subroutine for you. Simply do this:
+
+ use Sub::Name 'subname';
+ *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
+
+and things will Just Work.
+
+=head2 next::can
+
+Like C<next::method>, but just returns either
+a code reference or C<undef> to indicate that
+no further methods of this name exist.
+
+=head2 maybe::next::method
+
+In simple cases it is equivalent to:
+
+ $self->next::method(@_) if $self->next_can;
+
+But there are some cases where only this solution
+works (like "goto &maybe::next::method");
+
+=head1 SEE ALSO - C3 Links
+
+=head2 The original Dylan paper
+
+=over 4
+
+=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
+
+=back
+
+=head2 The prototype Perl 6 Object Model uses C3
+
+=over 4
+
+=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
+
+=back
+
+=head2 Parrot now uses C3
+
+=over 4
+
+=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
+
+=item L<http://use.perl.org/~autrijus/journal/25768>
+
+=back
+
+=head2 Python 2.3 MRO related links
+
+=over 4
+
+=item L<http://www.python.org/2.3/mro.html>
+
+=item L<http://www.python.org/2.2.2/descrintro.html#mro>
+
+=back
+
+=head2 C3 for TinyCLOS
+
+=over 4
+
+=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
+
+=back
+
+=head2 Class::C3
+
+=over 4
+
+=item L<Class::C3>
+
+=back
+
+=head1 AUTHOR
+
+Brandon L. Black, E<lt>blblack@gmail.comE<gt>
+
+Based on Stevan Little's L<Class::C3>
+
+=cut
package overload;
-our $VERSION = '1.04';
+our $VERSION = '1.05';
sub nil {}
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;
}
{
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;
}
dVAR;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
- /* HV_badAMAGIC_on(Sv_STASH(sv)); */
PL_amagic_generation++;
return 0;
--- /dev/null
+/* mro.c
+ *
+ * Copyright (c) 2007 Brandon L Black
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+=head1 MRO Functions
+
+These functions are related to the method resolution order of perl classes
+
+=cut
+*/
+
+#include "EXTERN.h"
+#include "perl.h"
+
+struct mro_meta*
+Perl_mro_meta_init(pTHX_ HV* stash)
+{
+ void* newmeta;
+
+ assert(stash);
+ assert(HvAUX(stash));
+ assert(!(HvAUX(stash)->xhv_mro_meta));
+ Newxz(newmeta, sizeof(struct mro_meta), char);
+ HvAUX(stash)->xhv_mro_meta = (struct mro_meta*)newmeta;
+ ((struct mro_meta*)newmeta)->sub_generation = 1;
+
+ /* Manually flag UNIVERSAL as being universal.
+ This happens early in perl booting (when universal.c
+ does the newXS calls for UNIVERSAL::*), and infects
+ other packages as they are added to UNIVERSAL's MRO
+ */
+ if(HvNAMELEN_get(stash) == 9
+ && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) {
+ HvMROMETA(stash)->is_universal = 1;
+ }
+
+ return newmeta;
+}
+
+#if defined(USE_ITHREADS)
+
+/* for sv_dup on new threads */
+struct mro_meta*
+Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
+{
+ void* newmeta_void;
+ struct mro_meta* newmeta;
+
+ assert(smeta);
+
+ Newx(newmeta_void, sizeof(struct mro_meta), char);
+ newmeta = (struct mro_meta*)newmeta_void;
+
+ newmeta->mro_which = smeta->mro_which;
+ newmeta->sub_generation = smeta->sub_generation;
+ newmeta->is_universal = smeta->is_universal;
+ newmeta->fake = smeta->fake;
+ newmeta->mro_linear_dfs = smeta->mro_linear_dfs
+ ? (AV*) SvREFCNT_inc(sv_dup((SV*)smeta->mro_linear_dfs, param))
+ : 0;
+ newmeta->mro_linear_c3 = smeta->mro_linear_c3
+ ? (AV*) SvREFCNT_inc(sv_dup((SV*)smeta->mro_linear_c3, param))
+ : 0;
+ newmeta->mro_isarev = smeta->mro_isarev
+ ? (HV*) SvREFCNT_inc(sv_dup((SV*)smeta->mro_isarev, param))
+ : 0;
+ newmeta->mro_nextmethod = smeta->mro_nextmethod
+ ? (HV*) SvREFCNT_inc(sv_dup((SV*)smeta->mro_nextmethod, param))
+ : 0;
+
+ return newmeta;
+}
+
+#endif /* USE_ITHREADS */
+
+/*
+=for apidoc mro_get_linear_isa_dfs
+
+Returns the Depth-First Search linearization of @ISA
+the given stash. The return value is a read-only AV*.
+C<level> should be 0 (it is used internally in this
+function's recursion).
+
+=cut
+*/
+AV*
+Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
+{
+ AV* retval;
+ GV** gvp;
+ GV* gv;
+ AV* av;
+ SV** svp;
+ I32 items;
+ AV* subrv;
+ SV** subrv_p;
+ I32 subrv_items;
+ const char* stashname;
+ struct mro_meta* meta;
+
+ assert(stash);
+ assert(HvAUX(stash));
+
+ stashname = HvNAME_get(stash);
+ if (!stashname)
+ Perl_croak(aTHX_
+ "Can't linearize anonymous symbol table");
+
+ if (level > 100)
+ Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
+ stashname);
+
+ meta = HvMROMETA(stash);
+ if((retval = meta->mro_linear_dfs)) {
+ /* return cache if valid */
+ return retval;
+ }
+
+ /* not in cache, make a new one */
+ retval = newAV();
+ av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
+
+ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
+ av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
+
+ if(av) {
+ HV* stored = (HV*)sv_2mortal((SV*)newHV());
+ svp = AvARRAY(av);
+ items = AvFILLp(av) + 1;
+ while (items--) {
+ SV* const sv = *svp++;
+ HV* const basestash = gv_stashsv(sv, 0);
+
+ if (!basestash) {
+ if(!hv_exists_ent(stored, sv, 0)) {
+ av_push(retval, newSVsv(sv));
+ hv_store_ent(stored, sv, &PL_sv_undef, 0);
+ }
+ }
+ else {
+ subrv = mro_get_linear_isa_dfs(basestash, level + 1);
+ subrv_p = AvARRAY(subrv);
+ subrv_items = AvFILLp(subrv) + 1;
+ while(subrv_items--) {
+ SV* subsv = *subrv_p++;
+ if(!hv_exists_ent(stored, subsv, 0)) {
+ av_push(retval, newSVsv(subsv));
+ hv_store_ent(stored, subsv, &PL_sv_undef, 0);
+ }
+ }
+ }
+ }
+ }
+
+ SvREADONLY_on(retval);
+ meta->mro_linear_dfs = retval;
+ return retval;
+}
+
+/*
+=for apidoc mro_get_linear_isa_c3
+
+Returns the C3 linearization of @ISA
+the given stash. The return value is a read-only AV*.
+C<level> should be 0 (it is used internally in this
+function's recursion).
+
+=cut
+*/
+
+AV*
+Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
+{
+ AV* retval;
+ GV** gvp;
+ GV* gv;
+ AV* isa;
+ const char* stashname;
+ STRLEN stashname_len;
+ struct mro_meta* meta;
+
+ assert(stash);
+ assert(HvAUX(stash));
+
+ stashname = HvNAME_get(stash);
+ stashname_len = HvNAMELEN_get(stash);
+ if (!stashname)
+ Perl_croak(aTHX_
+ "Can't linearize anonymous symbol table");
+
+ if (level > 100)
+ Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
+ stashname);
+
+ meta = HvMROMETA(stash);
+ if((retval = meta->mro_linear_c3)) {
+ /* return cache if valid */
+ return retval;
+ }
+
+ /* not in cache, make a new one */
+
+ retval = newAV();
+ av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
+
+ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
+ isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
+
+ if(isa && AvFILLp(isa) >= 0) {
+ SV** seqs_ptr;
+ I32 seqs_items;
+ HV* tails = (HV*)sv_2mortal((SV*)newHV());
+ AV* seqs = (AV*)sv_2mortal((SV*)newAV());
+ I32 items = AvFILLp(isa) + 1;
+ SV** isa_ptr = AvARRAY(isa);
+ while(items--) {
+ AV* isa_lin;
+ SV* isa_item = *isa_ptr++;
+ HV* isa_item_stash = gv_stashsv(isa_item, 0);
+ if(!isa_item_stash) {
+ isa_lin = newAV();
+ av_push(isa_lin, newSVsv(isa_item));
+ }
+ else {
+ isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
+ }
+ av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
+ }
+ av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
+
+ seqs_ptr = AvARRAY(seqs);
+ seqs_items = AvFILLp(seqs) + 1;
+ while(seqs_items--) {
+ AV* seq = (AV*)*seqs_ptr++;
+ I32 seq_items = AvFILLp(seq);
+ if(seq_items > 0) {
+ SV** seq_ptr = AvARRAY(seq) + 1;
+ while(seq_items--) {
+ SV* seqitem = *seq_ptr++;
+ HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
+ if(!he) {
+ hv_store_ent(tails, seqitem, newSViv(1), 0);
+ }
+ else {
+ SV* val = HeVAL(he);
+ sv_inc(val);
+ }
+ }
+ }
+ }
+
+ while(1) {
+ SV* seqhead = NULL;
+ SV* cand = NULL;
+ SV* winner = NULL;
+ SV* val;
+ HE* tail_entry;
+ AV* seq;
+ SV** avptr = AvARRAY(seqs);
+ items = AvFILLp(seqs)+1;
+ while(items--) {
+ SV** svp;
+ seq = (AV*)*avptr++;
+ if(AvFILLp(seq) < 0) continue;
+ svp = av_fetch(seq, 0, 0);
+ seqhead = *svp;
+ if(!winner) {
+ cand = seqhead;
+ if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
+ && (val = HeVAL(tail_entry))
+ && (SvIVx(val) > 0))
+ continue;
+ winner = newSVsv(cand);
+ av_push(retval, winner);
+ }
+ if(!sv_cmp(seqhead, winner)) {
+
+ /* this is basically shift(@seq) in void context */
+ SvREFCNT_dec(*AvARRAY(seq));
+ *AvARRAY(seq) = &PL_sv_undef;
+ AvARRAY(seq) = AvARRAY(seq) + 1;
+ AvMAX(seq)--;
+ AvFILLp(seq)--;
+
+ if(AvFILLp(seq) < 0) continue;
+ svp = av_fetch(seq, 0, 0);
+ seqhead = *svp;
+ tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
+ val = HeVAL(tail_entry);
+ sv_dec(val);
+ }
+ }
+ if(!cand) break;
+ if(!winner) {
+ SvREFCNT_dec(retval);
+ Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
+ "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
+ }
+ }
+ }
+
+ SvREADONLY_on(retval);
+ meta->mro_linear_c3 = retval;
+ return retval;
+}
+
+/*
+=for apidoc mro_get_linear_isa
+
+Returns either C<mro_get_linear_isa_c3> or
+C<mro_get_linear_isa_dfs> for the given stash,
+dependant upon which MRO is in effect
+for that stash. The return value is a
+read-only AV*.
+
+=cut
+*/
+AV*
+Perl_mro_get_linear_isa(pTHX_ HV *stash)
+{
+ struct mro_meta* meta;
+ assert(stash);
+ assert(HvAUX(stash));
+
+ meta = HvMROMETA(stash);
+ if(meta->mro_which == MRO_DFS) {
+ return mro_get_linear_isa_dfs(stash, 0);
+ } else if(meta->mro_which == MRO_C3) {
+ return mro_get_linear_isa_c3(stash, 0);
+ } else {
+ Perl_croak(aTHX_ "Internal error: invalid MRO!");
+ }
+}
+
+/*
+=for apidoc mro_isa_changed_in
+
+Takes the neccesary steps (cache invalidations, mostly)
+when the @ISA of the given package has changed. Invoked
+by the C<setisa> magic, should not need to invoke directly.
+
+=cut
+*/
+void
+Perl_mro_isa_changed_in(pTHX_ HV* stash)
+{
+ dVAR;
+ HV* isarev;
+ AV* linear_mro;
+ HE* iter;
+ SV** svp;
+ I32 items;
+ struct mro_meta* meta;
+ char* stashname;
+
+ stashname = HvNAME_get(stash);
+
+ /* wipe out the cached linearizations for this stash */
+ meta = HvMROMETA(stash);
+ SvREFCNT_dec((SV*)meta->mro_linear_dfs);
+ SvREFCNT_dec((SV*)meta->mro_linear_c3);
+ meta->mro_linear_dfs = NULL;
+ meta->mro_linear_c3 = NULL;
+
+ /* Wipe the global method cache if this package
+ is UNIVERSAL or one of its parents */
+ if(meta->is_universal)
+ PL_sub_generation++;
+
+ /* Wipe the local method cache otherwise */
+ else
+ meta->sub_generation++;
+
+ /* wipe next::method cache too */
+ if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
+
+ /* Iterate the isarev (classes that are our children),
+ wiping out their linearization and method caches */
+ if((isarev = meta->mro_isarev)) {
+ hv_iterinit(isarev);
+ while((iter = hv_iternext(isarev))) {
+ SV* revkey = hv_iterkeysv(iter);
+ HV* revstash = gv_stashsv(revkey, 0);
+ struct mro_meta* revmeta = HvMROMETA(revstash);
+ SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
+ SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
+ revmeta->mro_linear_dfs = NULL;
+ revmeta->mro_linear_c3 = NULL;
+ if(!meta->is_universal)
+ revmeta->sub_generation++;
+ if(revmeta->mro_nextmethod)
+ hv_clear(revmeta->mro_nextmethod);
+ }
+ }
+
+ /* we're starting at the 2nd element, skipping ourselves here */
+ linear_mro = mro_get_linear_isa(stash);
+ svp = AvARRAY(linear_mro) + 1;
+ items = AvFILLp(linear_mro);
+ while (items--) {
+ SV* const sv = *svp++;
+ struct mro_meta* mrometa;
+ HV* mroisarev;
+
+ HV* mrostash = gv_stashsv(sv, 0);
+ if(!mrostash) {
+ mrostash = gv_stashsv(sv, GV_ADD);
+ /*
+ We created the package on the fly, so
+ that we could store isarev information.
+ This flag lets gv_fetchmeth know about it,
+ so that it can still generate the very useful
+ "Can't locate package Foo for @Bar::ISA" warning.
+ */
+ HvMROMETA(mrostash)->fake = 1;
+ }
+
+ mrometa = HvMROMETA(mrostash);
+ mroisarev = mrometa->mro_isarev;
+
+ /* is_universal is viral */
+ if(meta->is_universal)
+ mrometa->is_universal = 1;
+
+ if(!mroisarev)
+ mroisarev = mrometa->mro_isarev = newHV();
+
+ if(!hv_exists(mroisarev, stashname, strlen(stashname)))
+ hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
+
+ if(isarev) {
+ hv_iterinit(isarev);
+ while((iter = hv_iternext(isarev))) {
+ SV* revkey = hv_iterkeysv(iter);
+ if(!hv_exists_ent(mroisarev, revkey, 0))
+ hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
+ }
+ }
+ }
+}
+
+/*
+=for apidoc mro_method_changed_in
+
+Like C<mro_isa_changed_in>, but invalidates method
+caching on any child classes of the given stash, so
+that they might notice the changes in this one.
+
+Ideally, all instances of C<PL_sub_generation++> in
+the perl source should be replaced by calls to this.
+Some already are, but some are more difficult to
+replace.
+
+Perl has always had problems with method caches
+getting out of sync when one directly manipulates
+stashes via things like C<%{Foo::} = %{Bar::}> or
+C<${Foo::}{bar} = ...> or the equivalent. If
+you do this in core or XS code, call this afterwards
+on the destination stash to get things back in sync.
+
+If you're doing such a thing from pure perl, use
+C<mro::method_changed_in(classname)>, which
+just calls this.
+
+=cut
+*/
+void
+Perl_mro_method_changed_in(pTHX_ HV *stash)
+{
+ struct mro_meta* meta = HvMROMETA(stash);
+ HV* isarev;
+ HE* iter;
+
+ /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
+ invalidate all method caches globally */
+ if(meta->is_universal) {
+ PL_sub_generation++;
+ return;
+ }
+
+ /* else, invalidate the method caches of all child classes,
+ but not itself */
+ if((isarev = meta->mro_isarev)) {
+ hv_iterinit(isarev);
+ while((iter = hv_iternext(isarev))) {
+ SV* revkey = hv_iterkeysv(iter);
+ HV* revstash = gv_stashsv(revkey, 0);
+ struct mro_meta* mrometa = HvMROMETA(revstash);
+ mrometa->sub_generation++;
+ if(mrometa->mro_nextmethod)
+ hv_clear(mrometa->mro_nextmethod);
+ }
+ }
+}
+
+/* These two are static helpers for next::method and friends,
+ and re-implement a bunch of the code from pp_caller() in
+ a more efficient manner for this particular usage.
+*/
+
+STATIC I32
+__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
+ I32 i;
+ for (i = startingblock; i >= 0; i--) {
+ if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
+ }
+ return i;
+}
+
+STATIC SV*
+__nextcan(pTHX_ SV* self, I32 throw_nomethod)
+{
+ register I32 cxix;
+ register const PERL_CONTEXT *ccstack = cxstack;
+ const PERL_SI *top_si = PL_curstackinfo;
+ HV* selfstash;
+ GV* cvgv;
+ SV *stashname;
+ const char *fq_subname;
+ const char *subname;
+ STRLEN fq_subname_len;
+ STRLEN stashname_len;
+ STRLEN subname_len;
+ SV* sv;
+ GV** gvp;
+ AV* linear_av;
+ SV** linear_svp;
+ SV* linear_sv;
+ HV* curstash;
+ GV* candidate = NULL;
+ CV* cand_cv = NULL;
+ const char *hvname;
+ I32 items;
+ struct mro_meta* selfmeta;
+ HV* nmcache;
+ HE* cache_entry;
+
+ if(sv_isobject(self))
+ selfstash = SvSTASH(SvRV(self));
+ else
+ selfstash = gv_stashsv(self, 0);
+
+ assert(selfstash);
+
+ hvname = HvNAME_get(selfstash);
+ if (!hvname)
+ Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
+
+ cxix = __dopoptosub_at(cxstack, cxstack_ix);
+
+ /* This block finds the contextually-enclosing fully-qualified subname,
+ much like looking at (caller($i))[3] until you find a real sub that
+ isn't ANON, etc */
+ for (;;) {
+ /* we may be in a higher stacklevel, so dig down deeper */
+ while (cxix < 0) {
+ if(top_si->si_type == PERLSI_MAIN)
+ Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
+ top_si = top_si->si_prev;
+ ccstack = top_si->si_cxstack;
+ cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
+ }
+
+ if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
+ || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
+ cxix = __dopoptosub_at(ccstack, cxix - 1);
+ continue;
+ }
+
+ {
+ const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
+ if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
+ if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
+ cxix = dbcxix;
+ continue;
+ }
+ }
+ }
+
+ cvgv = CvGV(ccstack[cxix].blk_sub.cv);
+
+ if(!isGV(cvgv)) {
+ cxix = __dopoptosub_at(ccstack, cxix - 1);
+ continue;
+ }
+
+ /* we found a real sub here */
+ sv = sv_2mortal(newSV(0));
+
+ gv_efullname3(sv, cvgv, NULL);
+
+ fq_subname = SvPVX(sv);
+ fq_subname_len = SvCUR(sv);
+
+ subname = strrchr(fq_subname, ':');
+ if(!subname)
+ Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
+
+ subname++;
+ subname_len = fq_subname_len - (subname - fq_subname);
+ if(subname_len == 8 && strEQ(subname, "__ANON__")) {
+ cxix = __dopoptosub_at(ccstack, cxix - 1);
+ continue;
+ }
+ break;
+ }
+
+ /* If we made it to here, we found our context */
+
+ selfmeta = HvMROMETA(selfstash);
+ if(!(nmcache = selfmeta->mro_nextmethod)) {
+ nmcache = selfmeta->mro_nextmethod = newHV();
+ }
+
+ if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
+ SV* val = HeVAL(cache_entry);
+ if(val == &PL_sv_undef) {
+ if(throw_nomethod)
+ Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
+ }
+ return val;
+ }
+
+ /* beyond here is just for cache misses, so perf isn't as critical */
+
+ stashname_len = subname - fq_subname - 2;
+ stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
+
+ linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
+
+ linear_svp = AvARRAY(linear_av);
+ items = AvFILLp(linear_av) + 1;
+
+ while (items--) {
+ linear_sv = *linear_svp++;
+ assert(linear_sv);
+ if(sv_eq(linear_sv, stashname))
+ break;
+ }
+
+ if(items > 0) {
+ while (items--) {
+ linear_sv = *linear_svp++;
+ assert(linear_sv);
+ curstash = gv_stashsv(linear_sv, FALSE);
+
+ if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
+ if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
+ (void*)linear_sv, hvname);
+ continue;
+ }
+
+ assert(curstash);
+
+ gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
+ if (!gvp) continue;
+
+ candidate = *gvp;
+ assert(candidate);
+
+ if (SvTYPE(candidate) != SVt_PVGV)
+ gv_init(candidate, curstash, subname, subname_len, TRUE);
+ if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
+ SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
+ hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
+ return (SV*)cand_cv;
+ }
+ }
+ }
+
+ hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
+ if(throw_nomethod)
+ Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
+ return &PL_sv_undef;
+}
+
+#include "XSUB.h"
+
+XS(XS_mro_get_linear_isa);
+XS(XS_mro_set_mro);
+XS(XS_mro_get_mro);
+XS(XS_mro_get_isarev);
+XS(XS_mro_is_universal);
+XS(XS_mro_get_global_sub_generation);
+XS(XS_mro_invalidate_all_method_caches);
+XS(XS_mro_get_sub_generation);
+XS(XS_mro_method_changed_in);
+XS(XS_next_can);
+XS(XS_next_method);
+XS(XS_maybe_next_method);
+
+void
+Perl_boot_core_mro(pTHX)
+{
+ dVAR;
+ static const char file[] = __FILE__;
+
+ newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
+ newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
+ newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
+ newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
+ newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
+ newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_generation, file, "");
+ newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_all_method_caches, file, "");
+ newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
+ newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
+ newXS("next::can", XS_next_can, file);
+ newXS("next::method", XS_next_method, file);
+ newXS("maybe::next::method", XS_maybe_next_method, file);
+}
+
+XS(XS_mro_get_linear_isa) {
+ dVAR;
+ dXSARGS;
+ AV* RETVAL;
+ HV* class_stash;
+ SV* classname;
+
+ PERL_UNUSED_ARG(cv);
+
+ if(items < 1 || items > 2)
+ Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+ if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+ if(items > 1) {
+ char* which = SvPV_nolen(ST(1));
+ if(strEQ(which, "dfs"))
+ RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
+ else if(strEQ(which, "c3"))
+ RETVAL = mro_get_linear_isa_c3(class_stash, 0);
+ else
+ Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
+ }
+ else {
+ RETVAL = mro_get_linear_isa(class_stash);
+ }
+
+ ST(0) = newRV_inc((SV*)RETVAL);
+ sv_2mortal(ST(0));
+ XSRETURN(1);
+}
+
+XS(XS_mro_set_mro)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ char* whichstr;
+ mro_alg which;
+ HV* class_stash;
+ struct mro_meta* meta;
+
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
+
+ classname = ST(0);
+ whichstr = SvPV_nolen(ST(1));
+ class_stash = gv_stashsv(classname, GV_ADD);
+ if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
+ meta = HvMROMETA(class_stash);
+
+ if(strEQ(whichstr, "dfs"))
+ which = MRO_DFS;
+ else if(strEQ(whichstr, "c3"))
+ which = MRO_C3;
+ else
+ Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
+
+ if(meta->mro_which != which) {
+ meta->mro_which = which;
+ /* Only affects local method cache, not
+ even child classes */
+ meta->sub_generation++;
+ if(meta->mro_nextmethod)
+ hv_clear(meta->mro_nextmethod);
+ }
+
+ XSRETURN_EMPTY;
+}
+
+
+XS(XS_mro_get_mro)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ HV* class_stash;
+ struct mro_meta* meta;
+
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+ if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+ meta = HvMROMETA(class_stash);
+
+ if(meta->mro_which == MRO_DFS)
+ ST(0) = sv_2mortal(newSVpvn("dfs", 3));
+ else
+ ST(0) = sv_2mortal(newSVpvn("c3", 2));
+
+ XSRETURN(1);
+}
+
+XS(XS_mro_get_isarev)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ HV* class_stash;
+ HV* isarev;
+
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
+
+ classname = ST(0);
+
+ class_stash = gv_stashsv(classname, 0);
+ if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+ SP -= items;
+
+ if((isarev = HvMROMETA(class_stash)->mro_isarev)) {
+ HE* iter;
+ hv_iterinit(isarev);
+ while((iter = hv_iternext(isarev)))
+ XPUSHs(hv_iterkeysv(iter));
+ }
+
+ PUTBACK;
+ return;
+}
+
+XS(XS_mro_is_universal)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ HV* class_stash;
+
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+ if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+ HvMROMETA(class_stash)->is_universal
+ ? XSRETURN_YES
+ : XSRETURN_NO;
+}
+
+XS(XS_mro_get_global_sub_generation)
+{
+ dVAR;
+ dXSARGS;
+
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
+
+ ST(0) = sv_2mortal(newSViv(PL_sub_generation));
+ XSRETURN(1);
+}
+
+XS(XS_mro_invalidate_all_method_caches)
+{
+ dVAR;
+ dXSARGS;
+
+ PERL_UNUSED_ARG(cv);
+
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
+
+ PL_sub_generation++;
+
+ XSRETURN_EMPTY;
+}
+
+XS(XS_mro_get_sub_generation)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ HV* class_stash;
+
+ PERL_UNUSED_ARG(cv);
+
+ if(items != 1)
+ Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+ if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+ ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
+ XSRETURN(1);
+}
+
+XS(XS_mro_method_changed_in)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ HV* class_stash;
+
+ PERL_UNUSED_ARG(cv);
+
+ if(items != 1)
+ Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
+
+ classname = ST(0);
+
+ class_stash = gv_stashsv(classname, 0);
+ if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
+
+ mro_method_changed_in(class_stash);
+
+ XSRETURN_EMPTY;
+}
+
+XS(XS_next_can)
+{
+ dVAR;
+ dXSARGS;
+ SV* self = ST(0);
+ SV* methcv = __nextcan(aTHX_ self, 0);
+
+ PERL_UNUSED_ARG(cv);
+ PERL_UNUSED_VAR(items);
+
+ if(methcv == &PL_sv_undef) {
+ ST(0) = &PL_sv_undef;
+ }
+ else {
+ ST(0) = sv_2mortal(newRV_inc(methcv));
+ }
+
+ XSRETURN(1);
+}
+
+XS(XS_next_method)
+{
+ dMARK;
+ dAX;
+ SV* self = ST(0);
+ SV* methcv = __nextcan(aTHX_ self, 1);
+
+ PERL_UNUSED_ARG(cv);
+
+ PL_markstack_ptr++;
+ call_sv(methcv, GIMME_V);
+}
+
+XS(XS_maybe_next_method)
+{
+ dMARK;
+ dAX;
+ SV* self = ST(0);
+ SV* methcv = __nextcan(aTHX_ self, 0);
+
+ PERL_UNUSED_ARG(cv);
+
+ if(methcv == &PL_sv_undef) {
+ ST(0) = &PL_sv_undef;
+ XSRETURN(1);
+ }
+
+ PL_markstack_ptr++;
+ call_sv(methcv, GIMME_V);
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
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;
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;
}
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);
}
}
GvCVGEN(gv) = 0;
- PL_sub_generation++;
+ mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
}
}
CvGV(cv) = gv;
if (name) {
GvCV(gv) = cv;
GvCVGEN(gv) = 0;
- PL_sub_generation++;
+ mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
}
CvGV(cv) = gv;
boot_core_PerlIO();
boot_core_UNIVERSAL();
boot_core_xsutils();
+ boot_core_mro();
if (xsinit)
(*xsinit)(aTHX); /* in case linked C routines want magical variables */
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
which in the case of success contains an alias for the subroutine, and sets
-up caching info for this glob. Similarly for all the searched stashes.
+up caching info for this glob.
This function grants C<"SUPER"> token as a postfix of the stash name. The
GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
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);
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);
}
}
PERL_CALLCONV GV* Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN len, const U32 flags)
__attribute__nonnull__(pTHX_1);
+PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1);
+
+#if defined(USE_ITHREADS)
+PERL_CALLCONV struct mro_meta* Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+
+#endif
+PERL_CALLCONV AV* Perl_mro_get_linear_isa(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV AV* Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV AV* Perl_mro_get_linear_isa_dfs(pTHX_ HV* stash, I32 level)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV void Perl_mro_isa_changed_in(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV void Perl_mro_method_changed_in(pTHX_ HV* stash)
+ __attribute__nonnull__(pTHX_1);
+
+PERL_CALLCONV void Perl_boot_core_mro(pTHX);
PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
__attribute__nonnull__(pTHX_2);
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;
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:
SvREFCNT_dec(GvCV(dstr));
GvCV(dstr) = NULL;
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
- PL_sub_generation++;
+ mro_method_changed_in(GvSTASH(dstr));
}
}
SAVEGENERICSV(*location);
}
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)
? (AV*) SvREFCNT_inc(
sv_dup((SV*)saux->xhv_backreferences, param))
: 0;
+
+ daux->xhv_mro_meta = saux->xhv_mro_meta
+ ? mro_meta_dup(saux->xhv_mro_meta, param)
+ : 0;
+
/* Record stashes for possible cloning in Perl_clone(). */
if (hvname)
av_push(param->stashes, dstr);
}
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;
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More;
+
+plan tests => 8;
+
+{
+ package MRO_A;
+ our @ISA = qw//;
+ package MRO_B;
+ our @ISA = qw//;
+ package MRO_C;
+ our @ISA = qw//;
+ package MRO_D;
+ our @ISA = qw/MRO_A MRO_B MRO_C/;
+ package MRO_E;
+ our @ISA = qw/MRO_A MRO_B MRO_C/;
+ package MRO_F;
+ our @ISA = qw/MRO_D MRO_E/;
+}
+
+is(mro::get_mro('MRO_F'), 'dfs');
+is_deeply(mro::get_linear_isa('MRO_F'),
+ [qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/]
+);
+mro::set_mro('MRO_F', 'c3');
+is(mro::get_mro('MRO_F'), 'c3');
+is_deeply(mro::get_linear_isa('MRO_F'),
+ [qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/]
+);
+
+my @isarev = sort { $a cmp $b } mro::get_isarev('MRO_B');
+is_deeply(\@isarev,
+ [qw/MRO_D MRO_E MRO_F/]
+);
+
+ok(!mro::is_universal('MRO_B'));
+
+@UNIVERSAL::ISA = qw/MRO_F/;
+ok(mro::is_universal('MRO_B'));
+
+@UNIVERSAL::ISA = ();
+ok(mro::is_universal('MRO_B'));
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 4;
+
+=pod
+
+This tests the classic diamond inheritence pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Diamond_A;
+ sub hello { 'Diamond_A::hello' }
+}
+{
+ package Diamond_B;
+ use base 'Diamond_A';
+}
+{
+ package Diamond_C;
+ use base 'Diamond_A';
+
+ sub hello { 'Diamond_C::hello' }
+}
+{
+ package Diamond_D;
+ use base ('Diamond_B', 'Diamond_C');
+ use mro 'c3';
+}
+
+is_deeply(
+ mro::get_linear_isa('Diamond_D'),
+ [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+ '... got the right MRO for Diamond_D');
+
+is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected');
+is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
+is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 4;
+
+=pod
+
+This tests the classic diamond inheritence pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Diamond_A;
+ sub hello { 'Diamond_A::hello' }
+}
+{
+ package Diamond_B;
+ use base 'Diamond_A';
+}
+{
+ package Diamond_C;
+ use base 'Diamond_A';
+
+ sub hello { 'Diamond_C::hello' }
+}
+{
+ package Diamond_D;
+ use base ('Diamond_B', 'Diamond_C');
+ use mro 'dfs';
+}
+
+is_deeply(
+ mro::get_linear_isa('Diamond_D'),
+ [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ],
+ '... got the right MRO for Diamond_D');
+
+is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected');
+is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
+is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
--- /dev/null
+#!./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');
--- /dev/null
+#!./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');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 4;
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My second example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(E,D): pass
+class A(B,C): pass
+
+ 6
+ ---
+Level 3 | O |
+ / --- \
+ / | \
+ / | \
+ / | \
+ --- --- ---
+Level 2 2 | E | 4 | D | | F | 5
+ --- --- ---
+ \ / \ /
+ \ / \ /
+ \ / \ /
+ --- ---
+Level 1 1 | B | | C | 3
+ --- ---
+ \ /
+ \ /
+ ---
+Level 0 0 | A |
+ ---
+
+>>> A.mro()
+(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
+<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
+<type 'object'>)
+
+=cut
+
+{
+ package Test::O;
+ use mro 'c3';
+
+ sub O_or_D { 'Test::O' }
+ sub O_or_F { 'Test::O' }
+
+ package Test::F;
+ use base 'Test::O';
+ use mro 'c3';
+
+ sub O_or_F { 'Test::F' }
+
+ package Test::E;
+ use base 'Test::O';
+ use mro 'c3';
+
+ package Test::D;
+ use base 'Test::O';
+ use mro 'c3';
+
+ sub O_or_D { 'Test::D' }
+ sub C_or_D { 'Test::D' }
+
+ package Test::C;
+ use base ('Test::D', 'Test::F');
+ use mro 'c3';
+
+ sub C_or_D { 'Test::C' }
+
+ package Test::B;
+ use base ('Test::E', 'Test::D');
+ use mro 'c3';
+
+ package Test::A;
+ use base ('Test::B', 'Test::C');
+ use mro 'c3';
+}
+
+is_deeply(
+ mro::get_linear_isa('Test::A'),
+ [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ],
+ '... got the right MRO for Test::A');
+
+is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch');
+is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch');
+
+# NOTE:
+# this test is particularly interesting because the p5 dispatch
+# would actually call Test::D before Test::C and Test::D is a
+# subclass of Test::C
+is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 4;
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My second example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(E,D): pass
+class A(B,C): pass
+
+ 6
+ ---
+Level 3 | O |
+ / --- \
+ / | \
+ / | \
+ / | \
+ --- --- ---
+Level 2 2 | E | 4 | D | | F | 5
+ --- --- ---
+ \ / \ /
+ \ / \ /
+ \ / \ /
+ --- ---
+Level 1 1 | B | | C | 3
+ --- ---
+ \ /
+ \ /
+ ---
+Level 0 0 | A |
+ ---
+
+>>> A.mro()
+(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
+<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
+<type 'object'>)
+
+=cut
+
+{
+ package Test::O;
+ use mro 'dfs';
+
+ sub O_or_D { 'Test::O' }
+ sub O_or_F { 'Test::O' }
+
+ package Test::F;
+ use base 'Test::O';
+ use mro 'dfs';
+
+ sub O_or_F { 'Test::F' }
+
+ package Test::E;
+ use base 'Test::O';
+ use mro 'dfs';
+
+ package Test::D;
+ use base 'Test::O';
+ use mro 'dfs';
+
+ sub O_or_D { 'Test::D' }
+ sub C_or_D { 'Test::D' }
+
+ package Test::C;
+ use base ('Test::D', 'Test::F');
+ use mro 'dfs';
+
+ sub C_or_D { 'Test::C' }
+
+ package Test::B;
+ use base ('Test::E', 'Test::D');
+ use mro 'dfs';
+
+ package Test::A;
+ use base ('Test::B', 'Test::C');
+ use mro 'dfs';
+}
+
+is_deeply(
+ mro::get_linear_isa('Test::A'),
+ [ qw(Test::A Test::B Test::E Test::O Test::D Test::C Test::F) ],
+ '... got the right MRO for Test::A');
+
+is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch');
+is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch');
+
+# NOTE:
+# this test is particularly interesting because the p5 dispatch
+# would actually call Test::D before Test::C and Test::D is a
+# subclass of Test::C
+is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch');
--- /dev/null
+#!./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');
+
--- /dev/null
+#!./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');
+
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 2;
+
+=pod
+
+This tests a strange bug found by Matt S. Trout
+while building DBIx::Class. Thanks Matt!!!!
+
+ <A>
+ / \
+<C> <B>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Diamond_A;
+ use mro 'c3';
+
+ sub foo { 'Diamond_A::foo' }
+}
+{
+ package Diamond_B;
+ use base 'Diamond_A';
+ use mro 'c3';
+
+ sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
+}
+{
+ package Diamond_C;
+ use mro 'c3';
+ use base 'Diamond_A';
+
+}
+{
+ package Diamond_D;
+ use base ('Diamond_C', 'Diamond_B');
+ use mro 'c3';
+
+ sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
+}
+
+is_deeply(
+ mro::get_linear_isa('Diamond_D'),
+ [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ],
+ '... got the right MRO for Diamond_D');
+
+is(Diamond_D->foo,
+ 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo',
+ '... got the right next::method dispatch path');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 2;
+
+=pod
+
+This tests a strange bug found by Matt S. Trout
+while building DBIx::Class. Thanks Matt!!!!
+
+ <A>
+ / \
+<C> <B>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Diamond_A;
+ use mro 'dfs';
+
+ sub foo { 'Diamond_A::foo' }
+}
+{
+ package Diamond_B;
+ use base 'Diamond_A';
+ use mro 'dfs';
+
+ sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
+}
+{
+ package Diamond_C;
+ use mro 'dfs';
+ use base 'Diamond_A';
+
+}
+{
+ package Diamond_D;
+ use base ('Diamond_C', 'Diamond_B');
+ use mro 'dfs';
+
+ sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
+}
+
+is_deeply(
+ mro::get_linear_isa('Diamond_D'),
+ [ qw(Diamond_D Diamond_C Diamond_A Diamond_B) ],
+ '... got the right MRO for Diamond_D');
+
+is(Diamond_D->foo,
+ 'Diamond_D::foo => Diamond_A::foo',
+ '... got the right next::method dispatch path');
--- /dev/null
+#!/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');
--- /dev/null
+#!./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');
--- /dev/null
+#!./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');
--- /dev/null
+#!./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');
--- /dev/null
+#!./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');
--- /dev/null
+#!./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');
--- /dev/null
+#!./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);
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+=pod
+
+This tests the classic diamond inheritence pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Diamond_A;
+ use mro 'c3';
+ sub hello { 'Diamond_A::hello' }
+ sub foo { 'Diamond_A::foo' }
+}
+{
+ package Diamond_B;
+ use base 'Diamond_A';
+ use mro 'c3';
+ sub foo { 'Diamond_B::foo => ' . (shift)->next::method() }
+}
+{
+ package Diamond_C;
+ use mro 'c3';
+ use base 'Diamond_A';
+
+ sub hello { 'Diamond_C::hello => ' . (shift)->next::method() }
+ sub foo { 'Diamond_C::foo => ' . (shift)->next::method() }
+}
+{
+ package Diamond_D;
+ use base ('Diamond_B', 'Diamond_C');
+ use mro 'c3';
+
+ sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }
+}
+
+is_deeply(
+ mro::get_linear_isa('Diamond_D'),
+ [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+ '... got the right MRO for Diamond_D');
+
+is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected');
+
+is(Diamond_D->can('hello')->('Diamond_D'),
+ 'Diamond_C::hello => Diamond_A::hello',
+ '... can(method) resolved itself as expected');
+
+is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'),
+ 'Diamond_C::hello => Diamond_A::hello',
+ '... can(method) resolved itself as expected');
+
+is(Diamond_D->foo,
+ 'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo',
+ '... method foo resolved itself as expected');
--- /dev/null
+#!/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 $@;
+ }
+}
--- /dev/null
+#!/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');
+
+
--- /dev/null
+#!/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{}');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+
+=pod
+
+This tests the classic diamond inheritence pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Diamond_A;
+ use mro 'c3';
+ sub bar { 'Diamond_A::bar' }
+ sub baz { 'Diamond_A::baz' }
+}
+{
+ package Diamond_B;
+ use base 'Diamond_A';
+ use mro 'c3';
+ sub baz { 'Diamond_B::baz => ' . (shift)->next::method() }
+}
+{
+ package Diamond_C;
+ use mro 'c3';
+ use base 'Diamond_A';
+ sub foo { 'Diamond_C::foo' }
+ sub buz { 'Diamond_C::buz' }
+
+ sub woz { 'Diamond_C::woz' }
+ sub maybe { 'Diamond_C::maybe' }
+}
+{
+ package Diamond_D;
+ use base ('Diamond_B', 'Diamond_C');
+ use mro 'c3';
+ sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }
+ sub bar { 'Diamond_D::bar => ' . (shift)->next::method() }
+ sub buz { 'Diamond_D::buz => ' . (shift)->baz() }
+ sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() }
+
+ sub woz { 'Diamond_D::woz can => ' . ((shift)->next::can() ? 1 : 0) }
+ sub noz { 'Diamond_D::noz can => ' . ((shift)->next::can() ? 1 : 0) }
+
+ sub maybe { 'Diamond_D::maybe => ' . ((shift)->maybe::next::method() || 0) }
+ sub moybe { 'Diamond_D::moybe => ' . ((shift)->maybe::next::method() || 0) }
+
+}
+
+is_deeply(
+ mro::get_linear_isa('Diamond_D'),
+ [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+ '... got the right MRO for Diamond_D');
+
+is(Diamond_D->foo, 'Diamond_D::foo => Diamond_C::foo', '... skipped B and went to C correctly');
+is(Diamond_D->bar, 'Diamond_D::bar => Diamond_A::bar', '... skipped B & C and went to A correctly');
+is(Diamond_D->baz, 'Diamond_B::baz => Diamond_A::baz', '... called B method, skipped C and went to A correctly');
+is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... called D method dispatched to , different method correctly');
+eval { Diamond_D->fuz };
+like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there');
+
+is(Diamond_D->woz, 'Diamond_D::woz can => 1', '... can re-dispatch figured out correctly');
+is(Diamond_D->noz, 'Diamond_D::noz can => 0', '... cannot re-dispatch figured out correctly');
+
+is(Diamond_D->maybe, 'Diamond_D::maybe => Diamond_C::maybe', '... redispatched D to C when it exists');
+is(Diamond_D->moybe, 'Diamond_D::moybe => 0', '... quietly failed redispatch from D');
--- /dev/null
+#!/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');
+
--- /dev/null
+#!./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');
+
--- /dev/null
+#!./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');
+
--- /dev/null
+#!./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???");
+ }
+}
--- /dev/null
+#!./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???");
+ }
+}
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 1;
+use mro;
+
+=pod
+
+example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
+
+ Object
+ ^
+ |
+ LifeForm
+ ^ ^
+ / \
+ Sentient BiPedal
+ ^ ^
+ | |
+ Intelligent Humanoid
+ ^ ^
+ \ /
+ Vulcan
+
+ define class <sentient> (<life-form>) end class;
+ define class <bipedal> (<life-form>) end class;
+ define class <intelligent> (<sentient>) end class;
+ define class <humanoid> (<bipedal>) end class;
+ define class <vulcan> (<intelligent>, <humanoid>) end class;
+
+=cut
+
+{
+ package Object;
+ use mro 'c3';
+
+ package LifeForm;
+ use mro 'c3';
+ use base 'Object';
+
+ package Sentient;
+ use mro 'c3';
+ use base 'LifeForm';
+
+ package BiPedal;
+ use mro 'c3';
+ use base 'LifeForm';
+
+ package Intelligent;
+ use mro 'c3';
+ use base 'Sentient';
+
+ package Humanoid;
+ use mro 'c3';
+ use base 'BiPedal';
+
+ package Vulcan;
+ use mro 'c3';
+ use base ('Intelligent', 'Humanoid');
+}
+
+is_deeply(
+ mro::get_linear_isa('Vulcan'),
+ [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ],
+ '... got the right MRO for the Vulcan Dylan Example');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 1;
+use mro;
+
+=pod
+
+example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
+
+ Object
+ ^
+ |
+ LifeForm
+ ^ ^
+ / \
+ Sentient BiPedal
+ ^ ^
+ | |
+ Intelligent Humanoid
+ ^ ^
+ \ /
+ Vulcan
+
+ define class <sentient> (<life-form>) end class;
+ define class <bipedal> (<life-form>) end class;
+ define class <intelligent> (<sentient>) end class;
+ define class <humanoid> (<bipedal>) end class;
+ define class <vulcan> (<intelligent>, <humanoid>) end class;
+
+=cut
+
+{
+ package Object;
+ use mro 'dfs';
+
+ package LifeForm;
+ use mro 'dfs';
+ use base 'Object';
+
+ package Sentient;
+ use mro 'dfs';
+ use base 'LifeForm';
+
+ package BiPedal;
+ use mro 'dfs';
+ use base 'LifeForm';
+
+ package Intelligent;
+ use mro 'dfs';
+ use base 'Sentient';
+
+ package Humanoid;
+ use mro 'dfs';
+ use base 'BiPedal';
+
+ package Vulcan;
+ use mro 'dfs';
+ use base ('Intelligent', 'Humanoid');
+}
+
+is_deeply(
+ mro::get_linear_isa('Vulcan'),
+ [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal) ],
+ '... got the right MRO for the Vulcan Dylan Example');
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__) };
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 */
if (strEQ(name, "UNIVERSAL"))
return TRUE;
- if (level > 100)
- Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
- hvname);
-
- gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
-
- if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (subgen = GvSV(gv))
- && (hv = GvHV(gv)))
- {
- if (SvIV(subgen) == (IV)PL_sub_generation) {
- SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
- if (svp) {
- SV * const sv = *svp;
-#ifdef DEBUGGING
- if (sv != &PL_sv_undef)
- DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
- name, hvname) );
-#endif
- return (sv == &PL_sv_yes);
- }
- }
- else {
- DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
- hvname) );
- hv_clear(hv);
- sv_setiv(subgen, PL_sub_generation);
+ stash_linear_isa = mro_get_linear_isa(stash);
+ svp = AvARRAY(stash_linear_isa) + 1;
+ items = AvFILLp(stash_linear_isa);
+ while (items--) {
+ SV* const basename_sv = *svp++;
+ HV* basestash = gv_stashsv(basename_sv, 0);
+ if (!basestash) {
+ if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Can't locate package %"SVf" for the parents of %s",
+ SVfARG(basename_sv), hvname);
+ continue;
}
+ if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
+ return TRUE;
}
- gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
-
- if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
- if (!hv || !subgen) {
- gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
-
- gv = *gvp;
-
- if (SvTYPE(gv) != SVt_PVGV)
- gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
-
- if (!hv)
- hv = GvHVn(gv);
- if (!subgen) {
- subgen = newSViv(PL_sub_generation);
- GvSV(gv) = subgen;
- }
- }
- if (hv) {
- SV** svp = AvARRAY(av);
- /* NOTE: No support for tied ISA */
- I32 items = AvFILLp(av) + 1;
- while (items--) {
- SV* const sv = *svp++;
- HV* const basestash = gv_stashsv(sv, 0);
- if (!basestash) {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Can't locate package %"SVf" for @%s::ISA",
- SVfARG(sv), hvname);
- continue;
- }
- if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
- (void)hv_store(hv,name,len,&PL_sv_yes,0);
- return TRUE;
- }
- }
- (void)hv_store(hv,name,len,&PL_sv_no,0);
- }
- }
return FALSE;
}
#### 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)
$(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)
..\dump.c \
..\globals.c \
..\gv.c \
+ ..\mro.c \
..\hv.c \
..\locale.c \
..\mathoms.c \
..\dump.c \
..\globals.c \
..\gv.c \
+ ..\mro.c \
..\hv.c \
..\mg.c \
..\op.c \
$(DLLDIR)\dump.obj \
$(DLLDIR)\globals.obj \
$(DLLDIR)\gv.obj \
+$(DLLDIR)\mro.obj \
$(DLLDIR)\hv.obj \
$(DLLDIR)\locale.obj \
$(DLLDIR)\mathoms.obj \
..\dump.c \
..\globals.c \
..\gv.c \
+ ..\mro.c \
..\hv.c \
..\locale.c \
..\mathoms.c \
projects / p5sagit/p5-mst-13.2.git / commitdiff