X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mro.c;h=fe776474d488c92c69f681f75e991c68a6ac9f74;hb=e061ec81dcb60a85554e31a39475b89528de42f0;hp=ba7883c129cd013ae9c66493bf288300d0325f51;hpb=553e831a35acc518a30a7514866e0d1440e894ef;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mro.c b/mro.c
index ba7883c..fe77647 100644
--- a/mro.c
+++ b/mro.c
@@ -37,16 +37,16 @@ Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
     SV **data;
     PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
 
-    data = Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
-			  which->name, which->length, which->kflags,
-			  HV_FETCH_JUST_SV, NULL, which->hash);
+    data = (SV **)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_c3 = MUTABLE_AV(*data);
+	smeta->mro_linear_current = *data;
 
     return *data;
 }
@@ -57,24 +57,24 @@ Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
 {
     PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
 
-    if (!smeta->mro_linear_dfs) {
+    if (!smeta->mro_linear_all) {
 	if (smeta->mro_which == which) {
 	    /* If all we need to store is the current MRO's data, then don't use
 	       memory on a hash with 1 element - store it direct, and signal
 	       this by leaving the would-be-hash NULL.  */
-	    smeta->mro_linear_c3 = MUTABLE_AV(data);
+	    smeta->mro_linear_current = data;
 	    return data;
 	} else {
 	    HV *const hv = newHV();
 	    /* Start with 2 buckets. It's unlikely we'll need more. */
 	    HvMAX(hv) = 1;	
-	    smeta->mro_linear_dfs = MUTABLE_AV(hv);
+	    smeta->mro_linear_all = hv;
 
-	    if (smeta->mro_linear_c3) {
+	    if (smeta->mro_linear_current) {
 		/* If we were storing something directly, put it in the hash
 		   before we lose it. */
 		Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, 
-					  MUTABLE_SV(smeta->mro_linear_c3));
+					  smeta->mro_linear_current);
 	    }
 	}
     }
@@ -85,10 +85,10 @@ Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
     if (smeta->mro_which == which) {
 	/* If we've been asked to store the private data for the current MRO,
 	   then cache it.  */
-	smeta->mro_linear_c3 = MUTABLE_AV(data);
+	smeta->mro_linear_current = data;
     }
 
-    if (!Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
+    if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
 			which->name, which->length, which->kflags,
 			HV_FETCH_ISSTORE, data, which->hash)) {
 	Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
@@ -105,8 +105,8 @@ Perl_mro_get_from_name(pTHX_ SV *name) {
 
     PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
 
-    data = Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
-			  HV_FETCH_JUST_SV, NULL, 0);
+    data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
+				 HV_FETCH_JUST_SV, NULL, 0);
     if (!data)
 	return NULL;
     assert(SvTYPE(*data) == SVt_IV);
@@ -160,16 +160,17 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
     Newx(newmeta, 1, struct mro_meta);
     Copy(smeta, newmeta, 1, struct mro_meta);
 
-    if (newmeta->mro_linear_dfs) {
-	newmeta->mro_linear_dfs
-	    = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param)));
+    if (newmeta->mro_linear_all) {
+	newmeta->mro_linear_all
+	    = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_all, param)));
 	/* This is just acting as a shortcut pointer, and will be automatically
 	   updated on the first get.  */
-	newmeta->mro_linear_c3 = NULL;
-    } else if (newmeta->mro_linear_c3) {
+	newmeta->mro_linear_current = NULL;
+    } else if (newmeta->mro_linear_current) {
 	/* Only the current MRO is stored, so this owns the data.  */
-	newmeta->mro_linear_c3
-	    = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_c3, param)));
+	newmeta->mro_linear_current
+	    = SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_current,
+				  param));
     }
 
     if (newmeta->mro_nextmethod)
@@ -184,41 +185,6 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
 
 #endif /* USE_ITHREADS */
 
-HV *
-Perl_get_isa_hash(pTHX_ HV *const stash)
-{
-    dVAR;
-    struct mro_meta *const meta = HvMROMETA(stash);
-
-    PERL_ARGS_ASSERT_GET_ISA_HASH;
-
-    if (!meta->isa) {
-	AV *const isa = mro_get_linear_isa(stash);
-	if (!meta->isa) {
-	    HV *const isa_hash = newHV();
-	    /* Linearisation didn't build it for us, so do it here.  */
-	    SV *const *svp = AvARRAY(isa);
-	    SV *const *const svp_end = svp + AvFILLp(isa) + 1;
-	    const HEK *const canon_name = HvNAME_HEK(stash);
-
-	    while (svp < svp_end) {
-		(void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
-	    }
-
-	    (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
-			     HEK_LEN(canon_name), HEK_FLAGS(canon_name),
-			     HV_FETCH_ISSTORE, &PL_sv_undef,
-			     HEK_HASH(canon_name));
-	    (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
-
-	    SvREADONLY_on(isa_hash);
-
-	    meta->isa = isa_hash;
-	}
-    }
-    return meta->isa;
-}
-
 /*
 =for apidoc mro_get_linear_isa_dfs
 
@@ -434,15 +400,15 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
 
     /* wipe out the cached linearizations for this stash */
     meta = HvMROMETA(stash);
-    if (meta->mro_linear_dfs) {
-	SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
-	meta->mro_linear_dfs = NULL;
+    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_c3 = NULL;
-    } else if (meta->mro_linear_c3) {
+	meta->mro_linear_current = NULL;
+    } else if (meta->mro_linear_current) {
 	/* Only the current MRO is stored, so this owns the data.  */
-	SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3));
-	meta->mro_linear_c3 = NULL;
+	SvREFCNT_dec(meta->mro_linear_current);
+	meta->mro_linear_current = NULL;
     }
     if (meta->isa) {
 	SvREFCNT_dec(meta->isa);
@@ -483,15 +449,15 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
 
             if(!revstash) continue;
             revmeta = HvMROMETA(revstash);
-	    if (revmeta->mro_linear_dfs) {
-		SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
-		revmeta->mro_linear_dfs = NULL;
+	    if (revmeta->mro_linear_all) {
+		SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
+		revmeta->mro_linear_all = NULL;
 		/* This is just acting as a shortcut pointer.  */
-		revmeta->mro_linear_c3 = NULL;
-	    } else if (revmeta->mro_linear_c3) {
+		revmeta->mro_linear_current = NULL;
+	    } else if (revmeta->mro_linear_current) {
 		/* Only the current MRO is stored, so this owns the data.  */
-		SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3));
-		revmeta->mro_linear_c3 = NULL;
+		SvREFCNT_dec(revmeta->mro_linear_current);
+		revmeta->mro_linear_current = NULL;
 	    }
             if(!is_universal)
                 revmeta->cache_gen++;
@@ -619,202 +585,47 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
     }
 }
 
-#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)
-{
-    dVAR;
-    static const char file[] = __FILE__;
-
-    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)
+Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
 {
-    dVAR;
-    dXSARGS;
-    SV* classname;
-    const struct mro_alg *which;
-    HV* class_stash;
-    struct mro_meta* meta;
+    const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
+ 
+    PERL_ARGS_ASSERT_MRO_SET_MRO;
 
-    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);
-
-    which = Perl_mro_get_from_name(aTHX_ ST(1));
     if (!which)
-        Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
+        Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
 
     if(meta->mro_which != which) {
-	if (meta->mro_linear_c3 && !meta->mro_linear_dfs) {
+	if (meta->mro_linear_current && !meta->mro_linear_all) {
 	    /* If we were storing something directly, put it in the hash before
 	       we lose it. */
 	    Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, 
-				      MUTABLE_SV(meta->mro_linear_c3));
+				      MUTABLE_SV(meta->mro_linear_current));
 	}
 	meta->mro_which = which;
 	/* Scrub our cached pointer to the private data.  */
-	meta->mro_linear_c3 = NULL;
+	meta->mro_linear_current = NULL;
         /* Only affects local method cache, not
            even child classes */
         meta->cache_gen++;
         if(meta->mro_nextmethod)
             hv_clear(meta->mro_nextmethod);
     }
-
-    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;
+#include "XSUB.h"
 
-    if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
-        || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
-        XSRETURN_YES;
-    else
-        XSRETURN_NO;
-}
+XS(XS_mro_method_changed_in);
 
-XS(XS_mro_invalidate_method_caches)
+void
+Perl_boot_core_mro(pTHX)
 {
     dVAR;
-    dXSARGS;
-
-    if (items != 0)
-	croak_xs_usage(cv, "");
+    static const char file[] = __FILE__;
 
-    PL_sub_generation++;
+    Perl_mro_register(aTHX_ &dfs_alg);
 
-    XSRETURN_EMPTY;
+    newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
 }
 
 XS(XS_mro_method_changed_in)
@@ -837,28 +648,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