Nicholas Clark
2008-12-27 21:23:42 UTC
In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/1e9bd1186a044d6e3506ed14fbe055b8f75f7641?hp=4e7245b5373225aafe95c40cba1590f590d1c782>
- Log -----------------------------------------------------------------
commit 1e9bd1186a044d6e3506ed14fbe055b8f75f7641
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 20:54:01 2008 +0000
Move all mro:: XS functions from mro.c to ext/mro/mro.xs, except for
mro::method_changed_in(), which is used by constant.
M MANIFEST
M ext/mro/mro.xs
D ext/mro/t/pluggable.t
M lib/overload.pm
M mro.c
M t/mro/pkg_gen.t
commit 9953ff723fac897df4afc6a69aaa7bfe5e8dc983
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 11:19:37 2008 +0000
In struct mro_meta, rename mro_linear_dfs to mro_linear_all, and change it from
AV * to HV *.
M hv.c
M hv.h
M mro.c
commit 3a6fa573ae4863261f94be7a4dad29a13b1652be
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 11:05:03 2008 +0000
In struct mro_meta, rename mro_linear_c3 to mro_linear_current, and change it
from AV * to SV *.
M hv.c
M hv.h
M mro.c
commit 31b9005d8ff165a414c5e3493027e1656d7e810f
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 14:32:59 2008 +0000
Break out the set-the-MRO logic from the XS_mro_set_mro into Perl_mro_set_mro(),
which can be called from C code (such as the guts of extensions).
M embed.fnc
M global.sym
M mro.c
M proto.h
commit 553e831a35acc518a30a7514866e0d1440e894ef
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 09:20:21 2008 +0000
Optimisation of the use of the meta structure - don't create a hash if all we
are dealing with is data for the current MRO. Instead the direct pointer "owns"
the (reference to the) data, with the hash pointer left as NULL to signal this.
M hv.c
M mro.c
commit 58d4c5dfb9bcf0d0f30468212e01c1f9c9d48ce3
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 08:39:14 2008 +0000
Remove the comment that the mro:: functions are actually in the core
interpreter, hence you don't actually need to use mro;
This should have remained an implementation detail, as it limits the scope to
move things around within a stable branch. So for now, remove the expectation.
M ext/mro/mro.pm
commit b2685f0c86badfc357584d8dbfb2bf17057ea226
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 00:20:35 2008 +0000
Proper pluggable Method Resolution Orders. 'c3' is now implemented outside the
core, in ext/mro/mro.xs. Also move mro::_nextcan() to mro.xs. It needs direct
access to S_mro_get_linear_isa_c3(), and nothing on CPAN calls it, except via
methods defined in mro.pm. Hence all users already require mro;
M .gitignore
M MANIFEST
M Makefile.SH
M embed.fnc
M embed.h
A ext/mro/Changes
A ext/mro/Makefile.PL
A ext/mro/mro.pm
A ext/mro/mro.xs
A ext/mro/t/pluggable.t
M hv.h
D lib/mro.pm
M mro.c
M proto.h
M t/mro/basic.t
M t/mro/inconsistent_c3.t
M t/mro/recursion_c3.t
M win32/Makefile
M win32/makefile.mk
commit c60bad7b8870cf2745c93e1b99cbb504daa780b2
Author: Nicholas Clark <***@ccl4.org>
Date: Fri Dec 26 21:31:47 2008 +0000
Explictly export Perl_mro_meta_init() so that HvMROMETA() can become part of the
public API and be used outside the core. However, leave Perl_mro_meta_init() as
a private implementation detail.
M embed.fnc
M embed.h
M global.sym
M hv.h
commit a3e6e81e81213c31f0612471c427044481a95287
Author: Nicholas Clark <***@ccl4.org>
Date: Fri Dec 26 18:26:53 2008 +0000
Add Perl_mro_register() to register Method Resolution Orders,
Perl_mro_get_from_name() to retrieve MROs by name, and PL_registered_mros to
store them in. Abolish the static array of mros, and instead register the dfs
and c3 MRO structures.
M embed.fnc
M embedvar.h
M global.sym
M intrpvar.h
M mro.c
M perl.c
M perlapi.h
M proto.h
M sv.c
commit 123892d916359369839f3896f283189be71dc32c
Author: Nicholas Clark <***@ccl4.org>
Date: Fri Dec 26 17:14:44 2008 +0000
Add MRO_GET_PRIVATE_DATA() to use the cached mro private data where possible.
M hv.h
M mro.c
commit fa60396f123333e92849ecaecffb9252458d6678
Author: Nicholas Clark <***@ccl4.org>
Date: Fri Dec 26 16:38:58 2008 +0000
Repurpose struct mro_meta to allow it to store cached linear ISA for arbitary
method resolution orders.
mro_linear_dfs becomes a hash holding the different MROs' private data.
mro_linear_c3 becomes a shortcut pointer to the current MRO's private data.
M embed.fnc
M global.sym
M hv.c
M hv.h
M mro.c
M proto.h
-----------------------------------------------------------------------
Summary of changes:
.gitignore | 1 +
MANIFEST | 5 +-
Makefile.SH | 1 +
embed.fnc | 14 +-
embed.h | 6 -
embedvar.h | 2 +
ext/mro/Changes | 6 +
ext/mro/Makefile.PL | 10 +
{lib => ext/mro}/mro.pm | 9 +-
ext/mro/mro.xs | 596 ++++++++++++++++++++++++++++++++++
global.sym | 6 +
hv.c | 13 +-
hv.h | 25 ++-
intrpvar.h | 6 +
lib/overload.pm | 6 +-
mro.c | 817 +++++++++--------------------------------------
perl.c | 4 +
perlapi.h | 2 +
proto.h | 34 ++-
sv.c | 2 +
t/mro/basic.t | 2 +
t/mro/inconsistent_c3.t | 2 +
t/mro/pkg_gen.t | 2 +
t/mro/recursion_c3.t | 2 +
win32/Makefile | 1 +
win32/makefile.mk | 1 +
26 files changed, 889 insertions(+), 686 deletions(-)
create mode 100644 ext/mro/Changes
create mode 100644 ext/mro/Makefile.PL
rename {lib => ext/mro}/mro.pm (98%)
create mode 100644 ext/mro/mro.xs
diff --git a/.gitignore b/.gitignore
index 9a11832..4b430f9 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
diff --git a/MANIFEST b/MANIFEST
index 3320f83..955dead 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -921,6 +921,10 @@ 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/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 +2462,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 736759d..ff50cfd 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)
diff --git a/embed.fnc b/embed.fnc
index cc3cf79..c76ca9d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2184,15 +2184,23 @@ XEMop |void |emulate_cop_io |NN const COP *const c|NN SV *const sv
: Used by SvRX and SvRXOK
XEMop |REGEXP *|get_re_arg|NULLOK SV *sv
-: Used in HvMROMETA() in gv.c, pp_hot.c, universal.c
-p |struct mro_meta* |mro_meta_init |NN HV* stash
+Aop |SV* |mro_get_private_data|NN struct mro_meta *const smeta \
+ |NN const struct mro_alg *const which
+Aop |SV* |mro_set_private_data|NN struct mro_meta *const smeta \
+ |NN const struct mro_alg *const which \
+ |NN SV *const data
+Aop |const struct mro_alg *|mro_get_from_name|NN SV *name
+Aop |void |mro_register |NN const struct mro_alg *mro
+Aop |void |mro_set_mro |NN struct mro_meta *const meta \
+ |NN SV *const name
+: Used in HvMROMETA(), which is public.
+Xpo |struct mro_meta* |mro_meta_init |NN HV* stash
#if defined(USE_ITHREADS)
: Only used in sv.c
p |struct mro_meta* |mro_meta_dup |NN struct mro_meta* smeta|NN CLONE_PARAMS* param
#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
diff --git a/embed.h b/embed.h
index a136947..6fa667a 100644
--- a/embed.h
+++ b/embed.h
@@ -1956,9 +1956,6 @@
#endif
#if !defined(HAS_SIGNBIT)
#endif
-#ifdef PERL_CORE
-#define mro_meta_init Perl_mro_meta_init
-#endif
#if defined(USE_ITHREADS)
#ifdef PERL_CORE
#define mro_meta_dup Perl_mro_meta_dup
@@ -1967,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
@@ -4324,7 +4320,6 @@
#if defined(PERL_CORE) || defined(PERL_EXT)
#endif
#ifdef PERL_CORE
-#define mro_meta_init(a) Perl_mro_meta_init(aTHX_ a)
#endif
#if defined(USE_ITHREADS)
#ifdef PERL_CORE
@@ -4334,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/embedvar.h b/embedvar.h
index 0502d00..9ca58c0 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -248,6 +248,7 @@
#define PL_regex_pad (vTHX->Iregex_pad)
#define PL_regex_padav (vTHX->Iregex_padav)
#define PL_reginterp_cnt (vTHX->Ireginterp_cnt)
+#define PL_registered_mros (vTHX->Iregistered_mros)
#define PL_regmatch_slab (vTHX->Iregmatch_slab)
#define PL_regmatch_state (vTHX->Iregmatch_state)
#define PL_rehash_seed (vTHX->Irehash_seed)
@@ -561,6 +562,7 @@
#define PL_Iregex_pad PL_regex_pad
#define PL_Iregex_padav PL_regex_padav
#define PL_Ireginterp_cnt PL_reginterp_cnt
+#define PL_Iregistered_mros PL_registered_mros
#define PL_Iregmatch_slab PL_regmatch_slab
#define PL_Iregmatch_state PL_regmatch_state
#define PL_Irehash_seed PL_rehash_seed
diff --git a/ext/mro/Changes b/ext/mro/Changes
new file mode 100644
index 0000000..0dd224e
--- /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 0000000..8ccd887
--- /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 <***@gmail.com>');
diff --git a/lib/mro.pm b/ext/mro/mro.pm
similarity index 98%
rename from lib/mro.pm
rename to ext/mro/mro.pm
index d4be79a..5a193e2 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__
@@ -64,8 +68,7 @@ implementation for older Perls.
It's possible to change the MRO of a given class either by using C<use
mro> as shown in the synopsis, or by using the L</mro::set_mro> function
-below. The functions in the mro namespace do not require loading the
-C<mro> module, as they are actually provided by the core perl interpreter.
+below.
The special methods C<next::method>, C<next::can>, and
C<maybe::next::method> are not available until this C<mro> module
diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs
new file mode 100644
index 0000000..c9c9779
--- /dev/null
+++ b/ext/mro/mro.xs
@@ -0,0 +1,596 @@
+#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_get_linear_isa(...)
+ PROTOTYPE: $;$
+ PREINIT:
+ AV* RETVAL;
+ HV* class_stash;
+ SV* classname;
+ PPCODE:
+ if(items < 1 || items > 2)
+ croak_xs_usage(cv, "classname [, type ]");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+
+ if(!class_stash) {
+ /* No stash exists yet, give them just the classname */
+ AV* isalin = newAV();
+ av_push(isalin, newSVsv(classname));
+ ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
+ XSRETURN(1);
+ }
+ else if(items > 1) {
+ const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
+ if (!algo)
+ Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
+ RETVAL = algo->resolve(aTHX_ class_stash, 0);
+ }
+ else {
+ RETVAL = mro_get_linear_isa(class_stash);
+ }
+ ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
+ sv_2mortal(ST(0));
+ XSRETURN(1);
+
+void
+mro_set_mro(...)
+ PROTOTYPE: $$
+ PREINIT:
+ SV* classname;
+ const struct mro_alg *which;
+ HV* class_stash;
+ struct mro_meta* meta;
+ PPCODE:
+ if (items != 2)
+ croak_xs_usage(cv, "classname, type");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, GV_ADD);
+ if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
+ meta = HvMROMETA(class_stash);
+
+ Perl_mro_set_mro(aTHX_ meta, ST(1));
+
+ XSRETURN_EMPTY;
+
+void
+mro_get_mro(...)
+ PROTOTYPE: $
+ PREINIT:
+ SV* classname;
+ HV* class_stash;
+ PPCODE:
+ if (items != 1)
+ croak_xs_usage(cv, "classname");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+
+ ST(0) = sv_2mortal(newSVpv(class_stash
+ ? HvMROMETA(class_stash)->mro_which->name
+ : "dfs", 0));
+ XSRETURN(1);
+
+void
+mro_get_isarev(...)
+ PROTOTYPE: $
+ PREINIT:
+ SV* classname;
+ HE* he;
+ HV* isarev;
+ AV* ret_array;
+ PPCODE:
+ if (items != 1)
+ croak_xs_usage(cv, "classname");
+
+ classname = ST(0);
+
+ he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+ isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
+
+ ret_array = newAV();
+ if(isarev) {
+ HE* iter;
+ hv_iterinit(isarev);
+ while((iter = hv_iternext(isarev)))
+ av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
+ }
+ mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
+
+ PUTBACK;
+
+void
+mro_is_universal(...)
+ PROTOTYPE: $
+ PREINIT:
+ SV* classname;
+ HV* isarev;
+ char* classname_pv;
+ STRLEN classname_len;
+ HE* he;
+ PPCODE:
+ if (items != 1)
+ croak_xs_usage(cv, "classname");
+
+ classname = ST(0);
+
+ classname_pv = SvPV(classname,classname_len);
+
+ he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+ isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
+
+ if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
+ || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+
+
+void
+mro_invalidate_method_caches(...)
+ PROTOTYPE:
+ PPCODE:
+ if (items != 0)
+ croak_xs_usage(cv, "");
+
+ PL_sub_generation++;
+
+ XSRETURN_EMPTY;
+
+void
+mro_get_pkg_gen(...)
+ PROTOTYPE: $
+ PREINIT:
+ SV* classname;
+ HV* class_stash;
+ PPCODE:
+ if(items != 1)
+ croak_xs_usage(cv, "classname");
+
+ classname = ST(0);
+
+ class_stash = gv_stashsv(classname, 0);
+
+ mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
+
+ PUTBACK;
+
+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/global.sym b/global.sym
index fe26578..5ec7ba3 100644
--- a/global.sym
+++ b/global.sym
@@ -769,6 +769,12 @@ Perl_my_strlcpy
Perl_signbit
Perl_emulate_cop_io
Perl_get_re_arg
+Perl_mro_get_private_data
+Perl_mro_set_private_data
+Perl_mro_get_from_name
+Perl_mro_register
+Perl_mro_set_mro
+Perl_mro_meta_init
Perl_mro_get_linear_isa
Perl_mro_method_changed_in
Perl_sys_init
diff --git a/hv.c b/hv.c
index adb5a4d..78a1097 100644
--- a/hv.c
+++ b/hv.c
@@ -1694,8 +1694,17 @@ S_hfreeentries(pTHX_ HV *hv)
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_linear_all) {
+ SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
+ meta->mro_linear_all = NULL;
+ /* This is just acting as a shortcut pointer. */
+ meta->mro_linear_current = NULL;
+ } else if (meta->mro_linear_current) {
+ /* Only the current MRO is stored, so this owns the data.
+ */
+ SvREFCNT_dec(meta->mro_linear_current);
+ meta->mro_linear_current = NULL;
+ }
if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
SvREFCNT_dec(meta->isa);
Safefree(meta);
diff --git a/hv.h b/hv.h
index f92ce9e..2265326 100644
--- a/hv.h
+++ b/hv.h
@@ -41,13 +41,21 @@ 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 {
- AV *mro_linear_dfs; /* cached dfs @ISA linearization */
- AV *mro_linear_c3; /* cached c3 @ISA linearization */
+ /* a hash holding the different MROs private data. */
+ HV *mro_linear_all;
+ /* a pointer directly to the current MROs private data. If mro_linear_all
+ is NULL, this owns the SV reference, else it is just a pointer to a
+ value stored in and owned by mro_linear_all. */
+ SV *mro_linear_current;
HV *mro_nextmethod; /* next::method caching */
U32 cache_gen; /* Bumping this invalidates our method cache */
U32 pkg_gen; /* Bumps when local methods/@ISA change */
@@ -55,6 +63,11 @@ struct mro_meta {
HV *isa; /* Everything this class @ISA */
};
+#define MRO_GET_PRIVATE_DATA(smeta, which) \
+ (((smeta)->mro_which && (which) == (smeta)->mro_which) \
+ ? (smeta)->mro_linear_current \
+ : Perl_mro_get_private_data(aTHX_ (smeta), (which)))
+
/* Subject to change.
Don't access this directly.
*/
@@ -254,7 +267,7 @@ C<SV*>.
caller's responsibility */
#define HvMROMETA(hv) (HvAUX(hv)->xhv_mro_meta \
? HvAUX(hv)->xhv_mro_meta \
- : mro_meta_init(hv))
+ : Perl_mro_meta_init(aTHX_ hv))
/* FIXME - all of these should use a UTF8 aware API, which should also involve
getting the length. */
diff --git a/intrpvar.h b/intrpvar.h
index 956b7de..4fa3c0d 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -681,6 +681,12 @@ PERLVARI(Idestroyhook, destroyable_proc_t, MEMBER_TO_FPTR(Perl_sv_destroyable))
PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */
#endif
+/* Register of known Method Resolution Orders.
+ What this actually points to is an implementation detail (it may change to
+ a structure incorporating a reference count - use mro_get_from_name to
+ retrieve a C<struct mro_alg *> */
+PERLVAR(Iregistered_mros, HV *)
+
/* If you are adding a U8 or U16, check to see if there are 'Space' comments
* above on where there are gaps which currently will be structure padding. */
diff --git a/lib/overload.pm b/lib/overload.pm
index e5b2f97..425da1b 100644
--- a/lib/overload.pm
+++ b/lib/overload.pm
@@ -1,6 +1,6 @@
package overload;
-our $VERSION = '1.06';
+our $VERSION = '1.07';
sub nil {}
@@ -104,6 +104,10 @@ sub AddrRef {
sub mycan { # Real can would leave stubs.
my ($package, $meth) = @_;
+ local $@;
+ local $!;
+ require mro;
+
my $mro = mro::get_linear_isa($package);
foreach my $p (@$mro) {
my $fqmeth = $p . q{::} . $meth;
diff --git a/mro.c b/mro.c
index 36ad3ba..c29d38e 100644
--- a/mro.c
+++ b/mro.c
@@ -27,29 +27,107 @@ These functions are related to the method resolution order of perl classes
#define PERL_IN_MRO_C
#include "perl.h"
-struct mro_alg {
- const char *name;
- AV *(*resolve)(pTHX_ HV* stash, U32 level);
-};
-
-/* First one is the default */
-static struct mro_alg mros[] = {
- {"dfs", S_mro_get_linear_isa_dfs},
- {"c3", S_mro_get_linear_isa_c3}
-};
-
-#define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
-
-static const struct mro_alg *
-S_get_mro_from_name(pTHX_ const char *const name) {
- const struct mro_alg *algo = mros;
- const struct mro_alg *const end = mros + NUMBER_OF_MROS;
- while (algo < end) {
- if(strEQ(name, algo->name))
- return algo;
- ++algo;
+static const struct mro_alg dfs_alg =
+ {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
+
+SV *
+Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
+ const struct mro_alg *const which)
+{
+ SV **data;
+ PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
+
+ data = Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
+ which->name, which->length, which->kflags,
+ HV_FETCH_JUST_SV, NULL, which->hash);
+ if (!data)
+ return NULL;
+
+ /* If we've been asked to look up the private data for the current MRO, then
+ cache it. */
+ if (smeta->mro_which == which)
+ smeta->mro_linear_current = *data;
+
+ return *data;
+}
+
+SV *
+Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
+ const struct mro_alg *const which, SV *const data)
+{
**** PATCH TRUNCATED AT 1000 LINES -- 1024 NOT SHOWN ****
--
Perl5 Master Repository
<http://perl5.git.perl.org/perl.git/commitdiff/1e9bd1186a044d6e3506ed14fbe055b8f75f7641?hp=4e7245b5373225aafe95c40cba1590f590d1c782>
- Log -----------------------------------------------------------------
commit 1e9bd1186a044d6e3506ed14fbe055b8f75f7641
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 20:54:01 2008 +0000
Move all mro:: XS functions from mro.c to ext/mro/mro.xs, except for
mro::method_changed_in(), which is used by constant.
M MANIFEST
M ext/mro/mro.xs
D ext/mro/t/pluggable.t
M lib/overload.pm
M mro.c
M t/mro/pkg_gen.t
commit 9953ff723fac897df4afc6a69aaa7bfe5e8dc983
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 11:19:37 2008 +0000
In struct mro_meta, rename mro_linear_dfs to mro_linear_all, and change it from
AV * to HV *.
M hv.c
M hv.h
M mro.c
commit 3a6fa573ae4863261f94be7a4dad29a13b1652be
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 11:05:03 2008 +0000
In struct mro_meta, rename mro_linear_c3 to mro_linear_current, and change it
from AV * to SV *.
M hv.c
M hv.h
M mro.c
commit 31b9005d8ff165a414c5e3493027e1656d7e810f
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 14:32:59 2008 +0000
Break out the set-the-MRO logic from the XS_mro_set_mro into Perl_mro_set_mro(),
which can be called from C code (such as the guts of extensions).
M embed.fnc
M global.sym
M mro.c
M proto.h
commit 553e831a35acc518a30a7514866e0d1440e894ef
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 09:20:21 2008 +0000
Optimisation of the use of the meta structure - don't create a hash if all we
are dealing with is data for the current MRO. Instead the direct pointer "owns"
the (reference to the) data, with the hash pointer left as NULL to signal this.
M hv.c
M mro.c
commit 58d4c5dfb9bcf0d0f30468212e01c1f9c9d48ce3
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 08:39:14 2008 +0000
Remove the comment that the mro:: functions are actually in the core
interpreter, hence you don't actually need to use mro;
This should have remained an implementation detail, as it limits the scope to
move things around within a stable branch. So for now, remove the expectation.
M ext/mro/mro.pm
commit b2685f0c86badfc357584d8dbfb2bf17057ea226
Author: Nicholas Clark <***@ccl4.org>
Date: Sat Dec 27 00:20:35 2008 +0000
Proper pluggable Method Resolution Orders. 'c3' is now implemented outside the
core, in ext/mro/mro.xs. Also move mro::_nextcan() to mro.xs. It needs direct
access to S_mro_get_linear_isa_c3(), and nothing on CPAN calls it, except via
methods defined in mro.pm. Hence all users already require mro;
M .gitignore
M MANIFEST
M Makefile.SH
M embed.fnc
M embed.h
A ext/mro/Changes
A ext/mro/Makefile.PL
A ext/mro/mro.pm
A ext/mro/mro.xs
A ext/mro/t/pluggable.t
M hv.h
D lib/mro.pm
M mro.c
M proto.h
M t/mro/basic.t
M t/mro/inconsistent_c3.t
M t/mro/recursion_c3.t
M win32/Makefile
M win32/makefile.mk
commit c60bad7b8870cf2745c93e1b99cbb504daa780b2
Author: Nicholas Clark <***@ccl4.org>
Date: Fri Dec 26 21:31:47 2008 +0000
Explictly export Perl_mro_meta_init() so that HvMROMETA() can become part of the
public API and be used outside the core. However, leave Perl_mro_meta_init() as
a private implementation detail.
M embed.fnc
M embed.h
M global.sym
M hv.h
commit a3e6e81e81213c31f0612471c427044481a95287
Author: Nicholas Clark <***@ccl4.org>
Date: Fri Dec 26 18:26:53 2008 +0000
Add Perl_mro_register() to register Method Resolution Orders,
Perl_mro_get_from_name() to retrieve MROs by name, and PL_registered_mros to
store them in. Abolish the static array of mros, and instead register the dfs
and c3 MRO structures.
M embed.fnc
M embedvar.h
M global.sym
M intrpvar.h
M mro.c
M perl.c
M perlapi.h
M proto.h
M sv.c
commit 123892d916359369839f3896f283189be71dc32c
Author: Nicholas Clark <***@ccl4.org>
Date: Fri Dec 26 17:14:44 2008 +0000
Add MRO_GET_PRIVATE_DATA() to use the cached mro private data where possible.
M hv.h
M mro.c
commit fa60396f123333e92849ecaecffb9252458d6678
Author: Nicholas Clark <***@ccl4.org>
Date: Fri Dec 26 16:38:58 2008 +0000
Repurpose struct mro_meta to allow it to store cached linear ISA for arbitary
method resolution orders.
mro_linear_dfs becomes a hash holding the different MROs' private data.
mro_linear_c3 becomes a shortcut pointer to the current MRO's private data.
M embed.fnc
M global.sym
M hv.c
M hv.h
M mro.c
M proto.h
-----------------------------------------------------------------------
Summary of changes:
.gitignore | 1 +
MANIFEST | 5 +-
Makefile.SH | 1 +
embed.fnc | 14 +-
embed.h | 6 -
embedvar.h | 2 +
ext/mro/Changes | 6 +
ext/mro/Makefile.PL | 10 +
{lib => ext/mro}/mro.pm | 9 +-
ext/mro/mro.xs | 596 ++++++++++++++++++++++++++++++++++
global.sym | 6 +
hv.c | 13 +-
hv.h | 25 ++-
intrpvar.h | 6 +
lib/overload.pm | 6 +-
mro.c | 817 +++++++++--------------------------------------
perl.c | 4 +
perlapi.h | 2 +
proto.h | 34 ++-
sv.c | 2 +
t/mro/basic.t | 2 +
t/mro/inconsistent_c3.t | 2 +
t/mro/pkg_gen.t | 2 +
t/mro/recursion_c3.t | 2 +
win32/Makefile | 1 +
win32/makefile.mk | 1 +
26 files changed, 889 insertions(+), 686 deletions(-)
create mode 100644 ext/mro/Changes
create mode 100644 ext/mro/Makefile.PL
rename {lib => ext/mro}/mro.pm (98%)
create mode 100644 ext/mro/mro.xs
diff --git a/.gitignore b/.gitignore
index 9a11832..4b430f9 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
diff --git a/MANIFEST b/MANIFEST
index 3320f83..955dead 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -921,6 +921,10 @@ 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/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 +2462,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 736759d..ff50cfd 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)
diff --git a/embed.fnc b/embed.fnc
index cc3cf79..c76ca9d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2184,15 +2184,23 @@ XEMop |void |emulate_cop_io |NN const COP *const c|NN SV *const sv
: Used by SvRX and SvRXOK
XEMop |REGEXP *|get_re_arg|NULLOK SV *sv
-: Used in HvMROMETA() in gv.c, pp_hot.c, universal.c
-p |struct mro_meta* |mro_meta_init |NN HV* stash
+Aop |SV* |mro_get_private_data|NN struct mro_meta *const smeta \
+ |NN const struct mro_alg *const which
+Aop |SV* |mro_set_private_data|NN struct mro_meta *const smeta \
+ |NN const struct mro_alg *const which \
+ |NN SV *const data
+Aop |const struct mro_alg *|mro_get_from_name|NN SV *name
+Aop |void |mro_register |NN const struct mro_alg *mro
+Aop |void |mro_set_mro |NN struct mro_meta *const meta \
+ |NN SV *const name
+: Used in HvMROMETA(), which is public.
+Xpo |struct mro_meta* |mro_meta_init |NN HV* stash
#if defined(USE_ITHREADS)
: Only used in sv.c
p |struct mro_meta* |mro_meta_dup |NN struct mro_meta* smeta|NN CLONE_PARAMS* param
#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
diff --git a/embed.h b/embed.h
index a136947..6fa667a 100644
--- a/embed.h
+++ b/embed.h
@@ -1956,9 +1956,6 @@
#endif
#if !defined(HAS_SIGNBIT)
#endif
-#ifdef PERL_CORE
-#define mro_meta_init Perl_mro_meta_init
-#endif
#if defined(USE_ITHREADS)
#ifdef PERL_CORE
#define mro_meta_dup Perl_mro_meta_dup
@@ -1967,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
@@ -4324,7 +4320,6 @@
#if defined(PERL_CORE) || defined(PERL_EXT)
#endif
#ifdef PERL_CORE
-#define mro_meta_init(a) Perl_mro_meta_init(aTHX_ a)
#endif
#if defined(USE_ITHREADS)
#ifdef PERL_CORE
@@ -4334,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/embedvar.h b/embedvar.h
index 0502d00..9ca58c0 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -248,6 +248,7 @@
#define PL_regex_pad (vTHX->Iregex_pad)
#define PL_regex_padav (vTHX->Iregex_padav)
#define PL_reginterp_cnt (vTHX->Ireginterp_cnt)
+#define PL_registered_mros (vTHX->Iregistered_mros)
#define PL_regmatch_slab (vTHX->Iregmatch_slab)
#define PL_regmatch_state (vTHX->Iregmatch_state)
#define PL_rehash_seed (vTHX->Irehash_seed)
@@ -561,6 +562,7 @@
#define PL_Iregex_pad PL_regex_pad
#define PL_Iregex_padav PL_regex_padav
#define PL_Ireginterp_cnt PL_reginterp_cnt
+#define PL_Iregistered_mros PL_registered_mros
#define PL_Iregmatch_slab PL_regmatch_slab
#define PL_Iregmatch_state PL_regmatch_state
#define PL_Irehash_seed PL_rehash_seed
diff --git a/ext/mro/Changes b/ext/mro/Changes
new file mode 100644
index 0000000..0dd224e
--- /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 0000000..8ccd887
--- /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 <***@gmail.com>');
diff --git a/lib/mro.pm b/ext/mro/mro.pm
similarity index 98%
rename from lib/mro.pm
rename to ext/mro/mro.pm
index d4be79a..5a193e2 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__
@@ -64,8 +68,7 @@ implementation for older Perls.
It's possible to change the MRO of a given class either by using C<use
mro> as shown in the synopsis, or by using the L</mro::set_mro> function
-below. The functions in the mro namespace do not require loading the
-C<mro> module, as they are actually provided by the core perl interpreter.
+below.
The special methods C<next::method>, C<next::can>, and
C<maybe::next::method> are not available until this C<mro> module
diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs
new file mode 100644
index 0000000..c9c9779
--- /dev/null
+++ b/ext/mro/mro.xs
@@ -0,0 +1,596 @@
+#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_get_linear_isa(...)
+ PROTOTYPE: $;$
+ PREINIT:
+ AV* RETVAL;
+ HV* class_stash;
+ SV* classname;
+ PPCODE:
+ if(items < 1 || items > 2)
+ croak_xs_usage(cv, "classname [, type ]");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+
+ if(!class_stash) {
+ /* No stash exists yet, give them just the classname */
+ AV* isalin = newAV();
+ av_push(isalin, newSVsv(classname));
+ ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
+ XSRETURN(1);
+ }
+ else if(items > 1) {
+ const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
+ if (!algo)
+ Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
+ RETVAL = algo->resolve(aTHX_ class_stash, 0);
+ }
+ else {
+ RETVAL = mro_get_linear_isa(class_stash);
+ }
+ ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
+ sv_2mortal(ST(0));
+ XSRETURN(1);
+
+void
+mro_set_mro(...)
+ PROTOTYPE: $$
+ PREINIT:
+ SV* classname;
+ const struct mro_alg *which;
+ HV* class_stash;
+ struct mro_meta* meta;
+ PPCODE:
+ if (items != 2)
+ croak_xs_usage(cv, "classname, type");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, GV_ADD);
+ if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
+ meta = HvMROMETA(class_stash);
+
+ Perl_mro_set_mro(aTHX_ meta, ST(1));
+
+ XSRETURN_EMPTY;
+
+void
+mro_get_mro(...)
+ PROTOTYPE: $
+ PREINIT:
+ SV* classname;
+ HV* class_stash;
+ PPCODE:
+ if (items != 1)
+ croak_xs_usage(cv, "classname");
+
+ classname = ST(0);
+ class_stash = gv_stashsv(classname, 0);
+
+ ST(0) = sv_2mortal(newSVpv(class_stash
+ ? HvMROMETA(class_stash)->mro_which->name
+ : "dfs", 0));
+ XSRETURN(1);
+
+void
+mro_get_isarev(...)
+ PROTOTYPE: $
+ PREINIT:
+ SV* classname;
+ HE* he;
+ HV* isarev;
+ AV* ret_array;
+ PPCODE:
+ if (items != 1)
+ croak_xs_usage(cv, "classname");
+
+ classname = ST(0);
+
+ he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+ isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
+
+ ret_array = newAV();
+ if(isarev) {
+ HE* iter;
+ hv_iterinit(isarev);
+ while((iter = hv_iternext(isarev)))
+ av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
+ }
+ mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
+
+ PUTBACK;
+
+void
+mro_is_universal(...)
+ PROTOTYPE: $
+ PREINIT:
+ SV* classname;
+ HV* isarev;
+ char* classname_pv;
+ STRLEN classname_len;
+ HE* he;
+ PPCODE:
+ if (items != 1)
+ croak_xs_usage(cv, "classname");
+
+ classname = ST(0);
+
+ classname_pv = SvPV(classname,classname_len);
+
+ he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+ isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
+
+ if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
+ || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+
+
+void
+mro_invalidate_method_caches(...)
+ PROTOTYPE:
+ PPCODE:
+ if (items != 0)
+ croak_xs_usage(cv, "");
+
+ PL_sub_generation++;
+
+ XSRETURN_EMPTY;
+
+void
+mro_get_pkg_gen(...)
+ PROTOTYPE: $
+ PREINIT:
+ SV* classname;
+ HV* class_stash;
+ PPCODE:
+ if(items != 1)
+ croak_xs_usage(cv, "classname");
+
+ classname = ST(0);
+
+ class_stash = gv_stashsv(classname, 0);
+
+ mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
+
+ PUTBACK;
+
+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/global.sym b/global.sym
index fe26578..5ec7ba3 100644
--- a/global.sym
+++ b/global.sym
@@ -769,6 +769,12 @@ Perl_my_strlcpy
Perl_signbit
Perl_emulate_cop_io
Perl_get_re_arg
+Perl_mro_get_private_data
+Perl_mro_set_private_data
+Perl_mro_get_from_name
+Perl_mro_register
+Perl_mro_set_mro
+Perl_mro_meta_init
Perl_mro_get_linear_isa
Perl_mro_method_changed_in
Perl_sys_init
diff --git a/hv.c b/hv.c
index adb5a4d..78a1097 100644
--- a/hv.c
+++ b/hv.c
@@ -1694,8 +1694,17 @@ S_hfreeentries(pTHX_ HV *hv)
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_linear_all) {
+ SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
+ meta->mro_linear_all = NULL;
+ /* This is just acting as a shortcut pointer. */
+ meta->mro_linear_current = NULL;
+ } else if (meta->mro_linear_current) {
+ /* Only the current MRO is stored, so this owns the data.
+ */
+ SvREFCNT_dec(meta->mro_linear_current);
+ meta->mro_linear_current = NULL;
+ }
if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
SvREFCNT_dec(meta->isa);
Safefree(meta);
diff --git a/hv.h b/hv.h
index f92ce9e..2265326 100644
--- a/hv.h
+++ b/hv.h
@@ -41,13 +41,21 @@ 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 {
- AV *mro_linear_dfs; /* cached dfs @ISA linearization */
- AV *mro_linear_c3; /* cached c3 @ISA linearization */
+ /* a hash holding the different MROs private data. */
+ HV *mro_linear_all;
+ /* a pointer directly to the current MROs private data. If mro_linear_all
+ is NULL, this owns the SV reference, else it is just a pointer to a
+ value stored in and owned by mro_linear_all. */
+ SV *mro_linear_current;
HV *mro_nextmethod; /* next::method caching */
U32 cache_gen; /* Bumping this invalidates our method cache */
U32 pkg_gen; /* Bumps when local methods/@ISA change */
@@ -55,6 +63,11 @@ struct mro_meta {
HV *isa; /* Everything this class @ISA */
};
+#define MRO_GET_PRIVATE_DATA(smeta, which) \
+ (((smeta)->mro_which && (which) == (smeta)->mro_which) \
+ ? (smeta)->mro_linear_current \
+ : Perl_mro_get_private_data(aTHX_ (smeta), (which)))
+
/* Subject to change.
Don't access this directly.
*/
@@ -254,7 +267,7 @@ C<SV*>.
caller's responsibility */
#define HvMROMETA(hv) (HvAUX(hv)->xhv_mro_meta \
? HvAUX(hv)->xhv_mro_meta \
- : mro_meta_init(hv))
+ : Perl_mro_meta_init(aTHX_ hv))
/* FIXME - all of these should use a UTF8 aware API, which should also involve
getting the length. */
diff --git a/intrpvar.h b/intrpvar.h
index 956b7de..4fa3c0d 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -681,6 +681,12 @@ PERLVARI(Idestroyhook, destroyable_proc_t, MEMBER_TO_FPTR(Perl_sv_destroyable))
PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */
#endif
+/* Register of known Method Resolution Orders.
+ What this actually points to is an implementation detail (it may change to
+ a structure incorporating a reference count - use mro_get_from_name to
+ retrieve a C<struct mro_alg *> */
+PERLVAR(Iregistered_mros, HV *)
+
/* If you are adding a U8 or U16, check to see if there are 'Space' comments
* above on where there are gaps which currently will be structure padding. */
diff --git a/lib/overload.pm b/lib/overload.pm
index e5b2f97..425da1b 100644
--- a/lib/overload.pm
+++ b/lib/overload.pm
@@ -1,6 +1,6 @@
package overload;
-our $VERSION = '1.06';
+our $VERSION = '1.07';
sub nil {}
@@ -104,6 +104,10 @@ sub AddrRef {
sub mycan { # Real can would leave stubs.
my ($package, $meth) = @_;
+ local $@;
+ local $!;
+ require mro;
+
my $mro = mro::get_linear_isa($package);
foreach my $p (@$mro) {
my $fqmeth = $p . q{::} . $meth;
diff --git a/mro.c b/mro.c
index 36ad3ba..c29d38e 100644
--- a/mro.c
+++ b/mro.c
@@ -27,29 +27,107 @@ These functions are related to the method resolution order of perl classes
#define PERL_IN_MRO_C
#include "perl.h"
-struct mro_alg {
- const char *name;
- AV *(*resolve)(pTHX_ HV* stash, U32 level);
-};
-
-/* First one is the default */
-static struct mro_alg mros[] = {
- {"dfs", S_mro_get_linear_isa_dfs},
- {"c3", S_mro_get_linear_isa_c3}
-};
-
-#define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
-
-static const struct mro_alg *
-S_get_mro_from_name(pTHX_ const char *const name) {
- const struct mro_alg *algo = mros;
- const struct mro_alg *const end = mros + NUMBER_OF_MROS;
- while (algo < end) {
- if(strEQ(name, algo->name))
- return algo;
- ++algo;
+static const struct mro_alg dfs_alg =
+ {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
+
+SV *
+Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
+ const struct mro_alg *const which)
+{
+ SV **data;
+ PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
+
+ data = Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
+ which->name, which->length, which->kflags,
+ HV_FETCH_JUST_SV, NULL, which->hash);
+ if (!data)
+ return NULL;
+
+ /* If we've been asked to look up the private data for the current MRO, then
+ cache it. */
+ if (smeta->mro_which == which)
+ smeta->mro_linear_current = *data;
+
+ return *data;
+}
+
+SV *
+Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
+ const struct mro_alg *const which, SV *const data)
+{
**** PATCH TRUNCATED AT 1000 LINES -- 1024 NOT SHOWN ****
--
Perl5 Master Repository