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