diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | MANIFEST | 6 | ||||
| -rw-r--r-- | Makefile.SH | 1 | ||||
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | ext/mro/Changes | 6 | ||||
| -rw-r--r-- | ext/mro/Makefile.PL | 10 | ||||
| -rw-r--r-- | ext/mro/mro.pm (renamed from lib/mro.pm) | 6 | ||||
| -rw-r--r-- | ext/mro/mro.xs | 439 | ||||
| -rw-r--r-- | ext/mro/t/pluggable.t | 26 | ||||
| -rw-r--r-- | hv.h | 10 | ||||
| -rw-r--r-- | mro.c | 442 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rw-r--r-- | t/mro/basic.t | 2 | ||||
| -rw-r--r-- | t/mro/inconsistent_c3.t | 2 | ||||
| -rw-r--r-- | t/mro/recursion_c3.t | 2 | ||||
| -rw-r--r-- | win32/Makefile | 1 | ||||
| -rw-r--r-- | win32/makefile.mk | 1 |
18 files changed, 508 insertions, 455 deletions
diff --git a/.gitignore b/.gitignore index 9a11832f71..4b430f9485 100644 --- a/.gitignore +++ b/.gitignore @@ -73,6 +73,7 @@ lib/App/ lib/Archive/Tar/t/src/long/foo.tbz lib/Archive/Tar/t/src/short/foo.tbz lib/IPC/Cmd/t/src/x.tgz +lib/mro.pm lib/TAP/ lib/Test/Harness.pm t/rantests @@ -921,6 +921,11 @@ ext/Module/Pluggable/lib/Devel/InnerPackage.pm Find inner packages ext/Module/Pluggable/lib/Module/Pluggable/Object.pm Module::Pluggable ext/Module/Pluggable/lib/Module/Pluggable.pm Module::Pluggable ext/Module/Pluggable/Makefile.PL Module::Pluggable +ext/mro/Changes mro extension +ext/mro/Makefile.PL mro extension +ext/mro/mro.pm mro extension +ext/mro/mro.xs mro extension +ext/mro/t/pluggable.t Test that c3 mro extension is actually pluggable ext/NDBM_File/hints/cygwin.pl Hint for NDBM_File for named architecture ext/NDBM_File/hints/dec_osf.pl Hint for NDBM_File for named architecture ext/NDBM_File/hints/dynixptx.pl Hint for NDBM_File for named architecture @@ -2458,7 +2463,6 @@ lib/Module/Load/t/to_load/LoadMe.pl Module::Load tests lib/Module/Load/t/to_load/Must/Be/Loaded.pm Module::Load tests lib/Module/Load/t/to_load/TestModule.pm Module::Load tests lib/Module/Load/t/to_load/ToBeLoaded Module::Load tests -lib/mro.pm mro extension lib/Net/Changes libnet lib/Net/Cmd.pm libnet lib/Net/Config.eg libnet diff --git a/Makefile.SH b/Makefile.SH index 736759df7e..ff50cfd0d7 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -1249,6 +1249,7 @@ _cleaner2: rm -f preload lib/re.pm rm -rf lib/Encode lib/Compress lib/Hash lib/re rm -rf lib/TAP lib/Module/Pluggable lib/App + rm -rf lib/mro rm -rf lib/IO/Compress lib/IO/Uncompress rm -f lib/ExtUtils/ParseXS/t/XSTest.c rm -f lib/ExtUtils/ParseXS/t/XSTest$(OBJ_EXT) @@ -2199,7 +2199,6 @@ p |struct mro_meta* |mro_meta_dup |NN struct mro_meta* smeta|NN CLONE_PARAMS* pa #endif Apd |AV* |mro_get_linear_isa|NN HV* stash #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT) -sd |AV* |mro_get_linear_isa_c3|NN HV* stash|U32 level sd |AV* |mro_get_linear_isa_dfs|NN HV* stash|U32 level #endif : Used in hv.c, mg.c, pp.c, sv.c @@ -1964,7 +1964,6 @@ #define mro_get_linear_isa Perl_mro_get_linear_isa #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE -#define mro_get_linear_isa_c3 S_mro_get_linear_isa_c3 #define mro_get_linear_isa_dfs S_mro_get_linear_isa_dfs #endif #endif @@ -4330,7 +4329,6 @@ #define mro_get_linear_isa(a) Perl_mro_get_linear_isa(aTHX_ a) #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE -#define mro_get_linear_isa_c3(a,b) S_mro_get_linear_isa_c3(aTHX_ a,b) #define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b) #endif #endif diff --git a/ext/mro/Changes b/ext/mro/Changes new file mode 100644 index 0000000000..0dd224e18a --- /dev/null +++ b/ext/mro/Changes @@ -0,0 +1,6 @@ +Revision history for Perl extension mro. + +1.01 Fri Dec 26 19:23:01 2008 + - original version; created by h2xs 1.23 with options + -b 5.10.0 -c -A -n mro --skip-ppport + Migrate code from the core's mro.c diff --git a/ext/mro/Makefile.PL b/ext/mro/Makefile.PL new file mode 100644 index 0000000000..8ccd8873fb --- /dev/null +++ b/ext/mro/Makefile.PL @@ -0,0 +1,10 @@ +use 5.010000; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + NAME => 'mro', + VERSION_FROM => 'mro.pm', # finds $VERSION + ABSTRACT_FROM => 'mro.pm', # retrieve abstract from module + MAN3PODS => {}, + AUTHOR => 'Brandon L. Black <blblack@gmail.com>'); diff --git a/lib/mro.pm b/ext/mro/mro.pm index d4be79a873..5f0ae9683e 100644 --- a/lib/mro.pm +++ b/ext/mro/mro.pm @@ -1,6 +1,7 @@ # mro.pm # # Copyright (c) 2007 Brandon L Black +# Copyright (c) 2008 Larry Wall and others # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the README file. @@ -11,7 +12,7 @@ use warnings; # mro.pm versions < 1.00 reserved for MRO::Compat # for partial back-compat to 5.[68].x -our $VERSION = '1.00'; +our $VERSION = '1.01'; sub import { mro::set_mro(scalar(caller), $_[1]) if $_[1]; @@ -36,6 +37,9 @@ sub method { return; } +require XSLoader; +XSLoader::load('mro', $VERSION); + 1; __END__ diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs new file mode 100644 index 0000000000..30f0d11302 --- /dev/null +++ b/ext/mro/mro.xs @@ -0,0 +1,439 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +static AV* +S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level); + +static const struct mro_alg c3_alg = + {S_mro_get_linear_isa_c3, "c3", 2, 0, 0}; + +/* +=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). + +You are responsible for C<SvREFCNT_inc()> on the +return value if you plan to store it anywhere +semi-permanently (otherwise it might be deleted +out from under you the next time the cache is +invalidated). + +=cut +*/ + +static AV* +S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) +{ + AV* retval; + GV** gvp; + GV* gv; + AV* isa; + const HEK* stashhek; + struct mro_meta* meta; + + assert(HvAUX(stash)); + + stashhek = HvNAME_HEK(stash); + if (!stashhek) + Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); + + if (level > 100) + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", + HEK_KEY(stashhek)); + + meta = HvMROMETA(stash); + + /* return cache if valid */ + if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) { + return retval; + } + + /* not in cache, make a new one */ + + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); + isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; + + /* For a better idea how the rest of this works, see the much clearer + pure perl version in Algorithm::C3 0.01: + http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm + (later versions go about it differently than this code for speed reasons) + */ + + if(isa && AvFILLp(isa) >= 0) { + SV** seqs_ptr; + I32 seqs_items; + HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); + AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV()))); + I32* heads; + + /* This builds @seqs, which is an array of arrays. + The members of @seqs are the MROs of + the members of @ISA, followed by @ISA itself. + */ + I32 items = AvFILLp(isa) + 1; + SV** isa_ptr = AvARRAY(isa); + while(items--) { + SV* const isa_item = *isa_ptr++; + HV* const isa_item_stash = gv_stashsv(isa_item, 0); + if(!isa_item_stash) { + /* if no stash, make a temporary fake MRO + containing just itself */ + AV* const isa_lin = newAV(); + av_push(isa_lin, newSVsv(isa_item)); + av_push(seqs, MUTABLE_SV(isa_lin)); + } + else { + /* recursion */ + AV* const isa_lin + = S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1); + av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin))); + } + } + av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa))); + + /* This builds "heads", which as an array of integer array + indices, one per seq, which point at the virtual "head" + of the seq (initially zero) */ + Newxz(heads, AvFILLp(seqs)+1, I32); + + /* This builds %tails, which has one key for every class + mentioned in the tail of any sequence in @seqs (tail meaning + everything after the first class, the "head"). The value + is how many times this key appears in the tails of @seqs. + */ + seqs_ptr = AvARRAY(seqs); + seqs_items = AvFILLp(seqs) + 1; + while(seqs_items--) { + AV *const seq = MUTABLE_AV(*seqs_ptr++); + I32 seq_items = AvFILLp(seq); + if(seq_items > 0) { + SV** seq_ptr = AvARRAY(seq) + 1; + while(seq_items--) { + SV* const seqitem = *seq_ptr++; + /* LVALUE fetch will create a new undefined SV if necessary + */ + HE* const he = hv_fetch_ent(tails, seqitem, 1, 0); + if(he) { + SV* const val = HeVAL(he); + /* This will increment undef to 1, which is what we + want for a newly created entry. */ + sv_inc(val); + } + } + } + } + + /* Initialize retval to build the return value in */ + retval = newAV(); + av_push(retval, newSVhek(stashhek)); /* us first */ + + /* This loop won't terminate until we either finish building + the MRO, or get an exception. */ + while(1) { + SV* cand = NULL; + SV* winner = NULL; + int s; + + /* "foreach $seq (@seqs)" */ + SV** const avptr = AvARRAY(seqs); + for(s = 0; s <= AvFILLp(seqs); s++) { + SV** svp; + AV * const seq = MUTABLE_AV(avptr[s]); + SV* seqhead; + if(!seq) continue; /* skip empty seqs */ + svp = av_fetch(seq, heads[s], 0); + seqhead = *svp; /* seqhead = head of this seq */ + if(!winner) { + HE* tail_entry; + SV* val; + /* if we haven't found a winner for this round yet, + and this seqhead is not in tails (or the count + for it in tails has dropped to zero), then this + seqhead is our new winner, and is added to the + final MRO immediately */ + 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); + /* note however that even when we find a winner, + we continue looping over @seqs to do housekeeping */ + } + if(!sv_cmp(seqhead, winner)) { + /* Once we have a winner (including the iteration + where we first found him), inc the head ptr + for any seq which had the winner as a head, + NULL out any seq which is now empty, + and adjust tails for consistency */ + + const int new_head = ++heads[s]; + if(new_head > AvFILLp(seq)) { + SvREFCNT_dec(avptr[s]); + avptr[s] = NULL; + } + else { + HE* tail_entry; + SV* val; + /* Because we know this new seqhead used to be + a tail, we can assume it is in tails and has + a positive value, which we need to dec */ + svp = av_fetch(seq, new_head, 0); + seqhead = *svp; + tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); + val = HeVAL(tail_entry); + sv_dec(val); + } + } + } + + /* if we found no candidates, we are done building the MRO. + !cand means no seqs have any entries left to check */ + if(!cand) { + Safefree(heads); + break; + } + + /* If we had candidates, but nobody won, then the @ISA + hierarchy is not C3-incompatible */ + if(!winner) { + /* we have to do some cleanup before we croak */ + + SvREFCNT_dec(retval); + Safefree(heads); + + Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': " + "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand)); + } + } + } + else { /* @ISA was undefined or empty */ + /* build a retval containing only ourselves */ + retval = newAV(); + av_push(retval, newSVhek(stashhek)); + } + + /* we don't want anyone modifying the cache entry but us, + and we do so by replacing it completely */ + SvREADONLY_on(retval); + + return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg, + MUTABLE_SV(retval))); + return retval; +} + + +/* 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; +} + +MODULE = mro PACKAGE = mro PREFIX = mro + +void +mro_nextcan(...) + PREINIT: + SV* self = ST(0); + const I32 throw_nomethod = SvIVX(ST(1)); + register I32 cxix = cxstack_ix; + register const PERL_CONTEXT *ccstack = cxstack; + const PERL_SI *top_si = PL_curstackinfo; + HV* selfstash; + SV *stashname; + const char *fq_subname; + const char *subname; + STRLEN stashname_len; + STRLEN subname_len; + SV* sv; + GV** gvp; + AV* linear_av; + SV** linear_svp; + const char *hvname; + I32 entries; + struct mro_meta* selfmeta; + HV* nmcache; + I32 i; + PPCODE: + PERL_UNUSED_ARG(cv); + + if(sv_isobject(self)) + selfstash = SvSTASH(SvRV(self)); + else + selfstash = gv_stashsv(self, GV_ADD); + + assert(selfstash); + + hvname = HvNAME_get(selfstash); + if (!hvname) + Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); + + /* 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 (also skips over pureperl next::method, etc) */ + for(i = 0; i < 2; i++) { + cxix = __dopoptosub_at(ccstack, cxix); + for (;;) { + GV* cvgv; + STRLEN fq_subname_len; + + /* 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; + } + cxix--; + } + + /* If we made it to here, we found our context */ + + /* Initialize the next::method cache for this stash + if necessary */ + selfmeta = HvMROMETA(selfstash); + if(!(nmcache = selfmeta->mro_nextmethod)) { + nmcache = selfmeta->mro_nextmethod = newHV(); + } + else { /* Use the cached coderef if it exists */ + HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0); + if (cache_entry) { + SV* const val = HeVAL(cache_entry); + if(val == &PL_sv_undef) { + if(throw_nomethod) + Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); + XSRETURN_EMPTY; + } + mXPUSHs(newRV_inc(val)); + XSRETURN(1); + } + } + + /* beyond here is just for cache misses, so perf isn't as critical */ + + stashname_len = subname - fq_subname - 2; + stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP); + + /* has ourselves at the top of the list */ + linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0); + + linear_svp = AvARRAY(linear_av); + entries = AvFILLp(linear_av) + 1; + + /* Walk down our MRO, skipping everything up + to the contextually enclosing class */ + while (entries--) { + SV * const linear_sv = *linear_svp++; + assert(linear_sv); + if(sv_eq(linear_sv, stashname)) + break; + } + + /* Now search the remainder of the MRO for the + same method name as the contextually enclosing + method */ + if(entries > 0) { + while (entries--) { + SV * const linear_sv = *linear_svp++; + HV* curstash; + GV* candidate; + CV* cand_cv; + + assert(linear_sv); + curstash = gv_stashsv(linear_sv, FALSE); + + if (!curstash) { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "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); + + /* Notably, we only look for real entries, not method cache + entries, because in C3 the method cache of a parent is not + valid for the child */ + if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { + SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv)); + (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0); + mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv))); + XSRETURN(1); + } + } + } + + (void)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); + XSRETURN_EMPTY; + +BOOT: + Perl_mro_register(aTHX_ &c3_alg); diff --git a/ext/mro/t/pluggable.t b/ext/mro/t/pluggable.t new file mode 100644 index 0000000000..be3fe060fc --- /dev/null +++ b/ext/mro/t/pluggable.t @@ -0,0 +1,26 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 3; + +{ + package A; +} + +@B::ISA = 'A'; +@C::ISA = 'A'; +@D::ISA = qw(B C); + +eval {mro::set_mro('D', 'c3')}; + +like $@, qr/Invalid mro name: 'c3'/; + +require mro; + +is_deeply(mro::get_linear_isa('D'), [qw(D B A C)], 'still dfs MRO'); + +mro::set_mro('D', 'c3'); + +is_deeply(mro::get_linear_isa('D'), [qw(D B C A)], 'c3 MRO'); @@ -41,9 +41,13 @@ struct shared_he { Use the funcs in mro.c */ - -/* structure may change, so not public yet */ -struct mro_alg; +struct mro_alg { + AV *(*resolve)(pTHX_ HV* stash, U32 level); + const char *name; + U16 length; + U16 kflags; /* For the hash API - set HVhek_UTF8 if name is UTF-8 */ + U32 hash; /* or 0 */ +}; struct mro_meta { /* repurposed as a hash holding the different MROs private data. */ @@ -27,21 +27,9 @@ These functions are related to the method resolution order of perl classes #define PERL_IN_MRO_C #include "perl.h" -struct mro_alg { - AV *(*resolve)(pTHX_ HV* stash, U32 level); - const char *name; - U16 length; - U16 kflags; /* For the hash API - set HVhek_UTF8 if name is UTF-8 */ - U32 hash; /* or 0 */ -}; - static const struct mro_alg dfs_alg = {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0}; -static const struct mro_alg c3_alg = - {S_mro_get_linear_isa_c3, "c3", 2, 0, 0}; - - SV * Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, const struct mro_alg *const which) @@ -357,225 +345,6 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) } /* -=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). - -You are responsible for C<SvREFCNT_inc()> on the -return value if you plan to store it anywhere -semi-permanently (otherwise it might be deleted -out from under you the next time the cache is -invalidated). - -=cut -*/ - -static AV* -S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) -{ - AV* retval; - GV** gvp; - GV* gv; - AV* isa; - const HEK* stashhek; - struct mro_meta* meta; - - PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3; - assert(HvAUX(stash)); - - stashhek = HvNAME_HEK(stash); - if (!stashhek) - Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); - - if (level > 100) - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - HEK_KEY(stashhek)); - - meta = HvMROMETA(stash); - - /* return cache if valid */ - if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) { - return retval; - } - - /* not in cache, make a new one */ - - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); - isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; - - /* For a better idea how the rest of this works, see the much clearer - pure perl version in Algorithm::C3 0.01: - http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm - (later versions go about it differently than this code for speed reasons) - */ - - if(isa && AvFILLp(isa) >= 0) { - SV** seqs_ptr; - I32 seqs_items; - HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); - AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV()))); - I32* heads; - - /* This builds @seqs, which is an array of arrays. - The members of @seqs are the MROs of - the members of @ISA, followed by @ISA itself. - */ - I32 items = AvFILLp(isa) + 1; - SV** isa_ptr = AvARRAY(isa); - while(items--) { - SV* const isa_item = *isa_ptr++; - HV* const isa_item_stash = gv_stashsv(isa_item, 0); - if(!isa_item_stash) { - /* if no stash, make a temporary fake MRO - containing just itself */ - AV* const isa_lin = newAV(); - av_push(isa_lin, newSVsv(isa_item)); - av_push(seqs, MUTABLE_SV(isa_lin)); - } - else { - /* recursion */ - AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); - av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin))); - } - } - av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa))); - - /* This builds "heads", which as an array of integer array - indices, one per seq, which point at the virtual "head" - of the seq (initially zero) */ - Newxz(heads, AvFILLp(seqs)+1, I32); - - /* This builds %tails, which has one key for every class - mentioned in the tail of any sequence in @seqs (tail meaning - everything after the first class, the "head"). The value - is how many times this key appears in the tails of @seqs. - */ - seqs_ptr = AvARRAY(seqs); - seqs_items = AvFILLp(seqs) + 1; - while(seqs_items--) { - AV *const seq = MUTABLE_AV(*seqs_ptr++); - I32 seq_items = AvFILLp(seq); - if(seq_items > 0) { - SV** seq_ptr = AvARRAY(seq) + 1; - while(seq_items--) { - SV* const seqitem = *seq_ptr++; - /* LVALUE fetch will create a new undefined SV if necessary - */ - HE* const he = hv_fetch_ent(tails, seqitem, 1, 0); - if(he) { - SV* const val = HeVAL(he); - /* This will increment undef to 1, which is what we - want for a newly created entry. */ - sv_inc(val); - } - } - } - } - - /* Initialize retval to build the return value in */ - retval = newAV(); - av_push(retval, newSVhek(stashhek)); /* us first */ - - /* This loop won't terminate until we either finish building - the MRO, or get an exception. */ - while(1) { - SV* cand = NULL; - SV* winner = NULL; - int s; - - /* "foreach $seq (@seqs)" */ - SV** const avptr = AvARRAY(seqs); - for(s = 0; s <= AvFILLp(seqs); s++) { - SV** svp; - AV * const seq = MUTABLE_AV(avptr[s]); - SV* seqhead; - if(!seq) continue; /* skip empty seqs */ - svp = av_fetch(seq, heads[s], 0); - seqhead = *svp; /* seqhead = head of this seq */ - if(!winner) { - HE* tail_entry; - SV* val; - /* if we haven't found a winner for this round yet, - and this seqhead is not in tails (or the count - for it in tails has dropped to zero), then this - seqhead is our new winner, and is added to the - final MRO immediately */ - 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); - /* note however that even when we find a winner, - we continue looping over @seqs to do housekeeping */ - } - if(!sv_cmp(seqhead, winner)) { - /* Once we have a winner (including the iteration - where we first found him), inc the head ptr - for any seq which had the winner as a head, - NULL out any seq which is now empty, - and adjust tails for consistency */ - - const int new_head = ++heads[s]; - if(new_head > AvFILLp(seq)) { - SvREFCNT_dec(avptr[s]); - avptr[s] = NULL; - } - else { - HE* tail_entry; - SV* val; - /* Because we know this new seqhead used to be - a tail, we can assume it is in tails and has - a positive value, which we need to dec */ - svp = av_fetch(seq, new_head, 0); - seqhead = *svp; - tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); - val = HeVAL(tail_entry); - sv_dec(val); - } - } - } - - /* if we found no candidates, we are done building the MRO. - !cand means no seqs have any entries left to check */ - if(!cand) { - Safefree(heads); - break; - } - - /* If we had candidates, but nobody won, then the @ISA - hierarchy is not C3-incompatible */ - if(!winner) { - /* we have to do some cleanup before we croak */ - - SvREFCNT_dec(retval); - Safefree(heads); - - Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': " - "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand)); - } - } - } - else { /* @ISA was undefined or empty */ - /* build a retval containing only ourselves */ - retval = newAV(); - av_push(retval, newSVhek(stashhek)); - } - - /* we don't want anyone modifying the cache entry but us, - and we do so by replacing it completely */ - SvREADONLY_on(retval); - - return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg, - MUTABLE_SV(retval))); - return retval; -} - -/* =for apidoc mro_get_linear_isa Returns either C<mro_get_linear_isa_c3> or @@ -809,20 +578,6 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) } } -/* 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; -} - #include "XSUB.h" XS(XS_mro_get_linear_isa); @@ -833,7 +588,6 @@ XS(XS_mro_is_universal); XS(XS_mro_invalidate_method_caches); XS(XS_mro_method_changed_in); XS(XS_mro_get_pkg_gen); -XS(XS_mro_nextcan); void Perl_boot_core_mro(pTHX) @@ -842,7 +596,6 @@ Perl_boot_core_mro(pTHX) static const char file[] = __FILE__; Perl_mro_register(aTHX_ &dfs_alg); - Perl_mro_register(aTHX_ &c3_alg); newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$"); newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$"); @@ -852,7 +605,6 @@ Perl_boot_core_mro(pTHX) newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, ""); newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$"); newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$"); - newXS("mro::_nextcan", XS_mro_nextcan, file); } XS(XS_mro_get_linear_isa) { @@ -1060,200 +812,6 @@ XS(XS_mro_get_pkg_gen) return; } -XS(XS_mro_nextcan) -{ - dVAR; - dXSARGS; - SV* self = ST(0); - const I32 throw_nomethod = SvIVX(ST(1)); - register I32 cxix = cxstack_ix; - register const PERL_CONTEXT *ccstack = cxstack; - const PERL_SI *top_si = PL_curstackinfo; - HV* selfstash; - SV *stashname; - const char *fq_subname; - const char *subname; - STRLEN stashname_len; - STRLEN subname_len; - SV* sv; - GV** gvp; - AV* linear_av; - SV** linear_svp; - const char *hvname; - I32 entries; - struct mro_meta* selfmeta; - HV* nmcache; - I32 i; - - PERL_UNUSED_ARG(cv); - - SP -= items; - - if(sv_isobject(self)) - selfstash = SvSTASH(SvRV(self)); - else - selfstash = gv_stashsv(self, GV_ADD); - - assert(selfstash); - - hvname = HvNAME_get(selfstash); - if (!hvname) - Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); - - /* 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 (also skips over pureperl next::method, etc) */ - for(i = 0; i < 2; i++) { - cxix = __dopoptosub_at(ccstack, cxix); - for (;;) { - GV* cvgv; - STRLEN fq_subname_len; - - /* 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; - } - cxix--; - } - - /* If we made it to here, we found our context */ - - /* Initialize the next::method cache for this stash - if necessary */ - selfmeta = HvMROMETA(selfstash); - if(!(nmcache = selfmeta->mro_nextmethod)) { - nmcache = selfmeta->mro_nextmethod = newHV(); - } - else { /* Use the cached coderef if it exists */ - HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0); - if (cache_entry) { - SV* const val = HeVAL(cache_entry); - if(val == &PL_sv_undef) { - if(throw_nomethod) - Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); - XSRETURN_EMPTY; - } - mXPUSHs(newRV_inc(val)); - XSRETURN(1); - } - } - - /* beyond here is just for cache misses, so perf isn't as critical */ - - stashname_len = subname - fq_subname - 2; - stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP); - - linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */ - - linear_svp = AvARRAY(linear_av); - entries = AvFILLp(linear_av) + 1; - - /* Walk down our MRO, skipping everything up - to the contextually enclosing class */ - while (entries--) { - SV * const linear_sv = *linear_svp++; - assert(linear_sv); - if(sv_eq(linear_sv, stashname)) - break; - } - - /* Now search the remainder of the MRO for the - same method name as the contextually enclosing - method */ - if(entries > 0) { - while (entries--) { - SV * const linear_sv = *linear_svp++; - HV* curstash; - GV* candidate; - CV* cand_cv; - - assert(linear_sv); - curstash = gv_stashsv(linear_sv, FALSE); - - if (!curstash) { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "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); - - /* Notably, we only look for real entries, not method cache - entries, because in C3 the method cache of a parent is not - valid for the child */ - if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { - SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv)); - (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0); - mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv))); - XSRETURN(1); - } - } - } - - (void)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); - XSRETURN_EMPTY; -} - /* * Local variables: * c-indentation-style: bsd @@ -6596,11 +6596,6 @@ PERL_CALLCONV AV* Perl_mro_get_linear_isa(pTHX_ HV* stash) assert(stash) #if defined(PERL_IN_MRO_C) || defined(PERL_DECL_PROT) -STATIC AV* S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3 \ - assert(stash) - STATIC AV* S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS \ diff --git a/t/mro/basic.t b/t/mro/basic.t index 6dce364285..e06622649e 100644 --- a/t/mro/basic.t +++ b/t/mro/basic.t @@ -5,6 +5,8 @@ use warnings; require q(./test.pl); plan(tests => 40); +require mro; + { package MRO_A; our @ISA = qw//; diff --git a/t/mro/inconsistent_c3.t b/t/mro/inconsistent_c3.t index 14f652cc6d..68d37950d4 100644 --- a/t/mro/inconsistent_c3.t +++ b/t/mro/inconsistent_c3.t @@ -11,6 +11,8 @@ BEGIN { require q(./test.pl); plan(tests => 1); +require mro; + =pod This example is take from: http://www.python.org/2.3/mro.html diff --git a/t/mro/recursion_c3.t b/t/mro/recursion_c3.t index 4030cfcd2c..cc45250714 100644 --- a/t/mro/recursion_c3.t +++ b/t/mro/recursion_c3.t @@ -14,6 +14,8 @@ require './test.pl'; plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM}; plan(tests => 8); +require mro; + =pod These are like the 010_complex_merge_classless test, diff --git a/win32/Makefile b/win32/Makefile index 20e4b4ef8e..1f1120c1fb 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -1186,6 +1186,7 @@ distclean: realclean -if exist $(LIBDIR)\App rmdir /s /q $(LIBDIR)\App -if exist $(LIBDIR)\Module\Pluggable rmdir /s /q $(LIBDIR)\Module\Pluggable -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP + -if exist $(LIBDIR)\mro rmdir /s /q $(LIBDIR)\mro -if exist $(LIBDIR)\IO\Compress rmdir /s /q $(LIBDIR)\IO\Compress -if exist $(LIBDIR)\IO\Socket rmdir /s /q $(LIBDIR)\IO\Socket -if exist $(LIBDIR)\IO\Uncompress rmdir /s /q $(LIBDIR)\IO\Uncompress diff --git a/win32/makefile.mk b/win32/makefile.mk index abf0f9e053..eac3619afb 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -1510,6 +1510,7 @@ distclean: realclean -if exist $(LIBDIR)\App rmdir /s /q $(LIBDIR)\App -if exist $(LIBDIR)\Module\Pluggable rmdir /s /q $(LIBDIR)\Module\Pluggable -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP + -if exist $(LIBDIR)\mro rmdir /s /q $(LIBDIR)\mro -if exist $(LIBDIR)\IO\Compress rmdir /s /q $(LIBDIR)\IO\Compress -if exist $(LIBDIR)\IO\Socket rmdir /s /q $(LIBDIR)\IO\Socket -if exist $(LIBDIR)\IO\Uncompress rmdir /s /q $(LIBDIR)\IO\Uncompress |