From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 27 Dec 2008 20:54:01 +0000 (+0000)
Subject: Move all mro:: XS functions from mro.c to ext/mro/mro.xs, except for
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1e9bd1186a044d6e3506ed14fbe055b8;p=p5sagit%2Fp5-mst-13.2.git

Move all mro:: XS functions from mro.c to ext/mro/mro.xs, except for
mro::method_changed_in(), which is used by constant.
---

diff --git a/MANIFEST b/MANIFEST
index 16fd217..955dead 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -925,7 +925,6 @@ 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
diff --git a/ext/mro/mro.xs b/ext/mro/mro.xs
index 30f0d11..c9c9779 100644
--- a/ext/mro/mro.xs
+++ b/ext/mro/mro.xs
@@ -242,10 +242,167 @@ __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
     return i;
 }
 
-MODULE = mro		PACKAGE = mro		PREFIX = mro
+MODULE = mro		PACKAGE = mro		PREFIX = mro_
 
 void
-mro_nextcan(...)
+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));
diff --git a/ext/mro/t/pluggable.t b/ext/mro/t/pluggable.t
deleted file mode 100644
index be3fe06..0000000
--- a/ext/mro/t/pluggable.t
+++ /dev/null
@@ -1,26 +0,0 @@
-#!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');
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 6d7730d..c29d38e 100644
--- a/mro.c
+++ b/mro.c
@@ -650,14 +650,7 @@ Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
 
 #include "XSUB.h"
 
-XS(XS_mro_get_linear_isa);
-XS(XS_mro_set_mro);
-XS(XS_mro_get_mro);
-XS(XS_mro_get_isarev);
-XS(XS_mro_is_universal);
-XS(XS_mro_invalidate_method_caches);
 XS(XS_mro_method_changed_in);
-XS(XS_mro_get_pkg_gen);
 
 void
 Perl_boot_core_mro(pTHX)
@@ -667,163 +660,7 @@ Perl_boot_core_mro(pTHX)
 
     Perl_mro_register(aTHX_ &dfs_alg);
 
-    newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
-    newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
-    newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
-    newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
-    newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
-    newXSproto("mro::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, "$");
-}
-
-XS(XS_mro_get_linear_isa) {
-    dVAR;
-    dXSARGS;
-    AV* RETVAL;
-    HV* class_stash;
-    SV* classname;
-
-    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);
-}
-
-XS(XS_mro_set_mro)
-{
-    dVAR;
-    dXSARGS;
-    SV* classname;
-    HV* class_stash;
-    struct mro_meta* meta;
-
-    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;
-}
-
-
-XS(XS_mro_get_mro)
-{
-    dVAR;
-    dXSARGS;
-    SV* classname;
-    HV* class_stash;
-
-    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);
-}
-
-XS(XS_mro_get_isarev)
-{
-    dVAR;
-    dXSARGS;
-    SV* classname;
-    HE* he;
-    HV* isarev;
-    AV* ret_array;
-
-    if (items != 1)
-	croak_xs_usage(cv, "classname");
-
-    classname = ST(0);
-
-    SP -= items;
-
-    
-    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;
-    return;
-}
-
-XS(XS_mro_is_universal)
-{
-    dVAR;
-    dXSARGS;
-    SV* classname;
-    HV* isarev;
-    char* classname_pv;
-    STRLEN classname_len;
-    HE* he;
-
-    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;
-}
-
-XS(XS_mro_invalidate_method_caches)
-{
-    dVAR;
-    dXSARGS;
-
-    if (items != 0)
-	croak_xs_usage(cv, "");
-
-    PL_sub_generation++;
-
-    XSRETURN_EMPTY;
 }
 
 XS(XS_mro_method_changed_in)
@@ -846,28 +683,6 @@ XS(XS_mro_method_changed_in)
     XSRETURN_EMPTY;
 }
 
-XS(XS_mro_get_pkg_gen)
-{
-    dVAR;
-    dXSARGS;
-    SV* classname;
-    HV* class_stash;
-
-    if(items != 1)
-	croak_xs_usage(cv, "classname");
-    
-    classname = ST(0);
-
-    class_stash = gv_stashsv(classname, 0);
-
-    SP -= items;
-
-    mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
-    
-    PUTBACK;
-    return;
-}
-
 /*
  * Local variables:
  * c-indentation-style: bsd
diff --git a/t/mro/pkg_gen.t b/t/mro/pkg_gen.t
index e1f5eb0..0d319fa 100644
--- a/t/mro/pkg_gen.t
+++ b/t/mro/pkg_gen.t
@@ -6,6 +6,8 @@ use warnings;
 chdir 't' if -d 't';
 require q(./test.pl); plan(tests => 7);
 
+require mro;
+
 {
     package Foo;
     our @ISA = qw//;