コード例 #1
0
ファイル: gv.c プロジェクト: fduhia/metamage_1
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
    register const char *nend;
    const char *nsplit = 0;
    GV* gv;

    for (nend = name; *nend; nend++) {
	if (*nend == '\'')
	    nsplit = nend;
	else if (*nend == ':' && *(nend + 1) == ':')
	    nsplit = ++nend;
    }
    if (nsplit) {
	const char *origname = name;
	name = nsplit + 1;
	if (*nsplit == ':')
	    --nsplit;
	if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
	    /* ->SUPER::method should really be looked up in original stash */
	    SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
						  CopSTASHPV(PL_curcop)));
	    stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
	    DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
			 origname, HvNAME(stash), name) );
	}
	else
	    stash = gv_stashpvn(origname, nsplit - origname, TRUE);
    }

    gv = gv_fetchmeth(stash, name, nend - name, 0);
    if (!gv) {
	if (strEQ(name,"import") || strEQ(name,"unimport"))
	    gv = (GV*)&PL_sv_yes;
	else if (autoload)
	    gv = gv_autoload4(stash, name, nend - name, TRUE);
    }
    else if (autoload) {
	CV* cv = GvCV(gv);
	if (!CvROOT(cv) && !CvXSUB(cv)) {
	    GV* stubgv;
	    GV* autogv;

	    if (CvANON(cv))
		stubgv = gv;
	    else {
		stubgv = CvGV(cv);
		if (GvCV(stubgv) != cv)		/* orphaned import */
		    stubgv = gv;
	    }
	    autogv = gv_autoload4(GvSTASH(stubgv),
				  GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
	    if (autogv)
		gv = autogv;
	}
    }

    return gv;
}
コード例 #2
0
ファイル: Obj.c プロジェクト: gitpan/KinoSearch
static void
S_lazy_init_host_obj(kino_Obj *self) 
{
    SV *inner_obj = newSV(0);
    SvOBJECT_on(inner_obj);
    PL_sv_objcount++;
    SvUPGRADE(inner_obj, SVt_PVMG);
    sv_setiv(inner_obj, PTR2IV(self));

    // Connect class association.
    kino_CharBuf *class_name = Kino_VTable_Get_Name(self->vtable);
    HV *stash = gv_stashpvn((char*)Kino_CB_Get_Ptr8(class_name),
        Kino_CB_Get_Size(class_name), TRUE);
    SvSTASH_set(inner_obj, (HV*)SvREFCNT_inc(stash));

    /* Up till now we've been keeping track of the refcount in
     * self->ref.count.  We're replacing ref.count with ref.host_obj, which
     * will assume responsibility for maintaining the refcount.  ref.host_obj
     * starts off with a refcount of 1, so we need to transfer any refcounts
     * in excess of that. */
    size_t old_refcount = self->ref.count;
    self->ref.host_obj = inner_obj;
    while (old_refcount > 1) {
        SvREFCNT_inc_simple_void_NN(inner_obj);
        old_refcount--;
    }
}
コード例 #3
0
ファイル: gv.c プロジェクト: fduhia/metamage_1
HV*
Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
{
    register char *ptr;
    STRLEN len;
    ptr = SvPV(sv,len);
    return gv_stashpvn(ptr, len, create);
}
コード例 #4
0
ファイル: gv.c プロジェクト: gitpan/ponie
/* The "gv" parameter should be the glob known to Perl code as *!
 * The scalar must already have been magicalized.
 */
STATIC void
S_require_errno(pTHX_ GV *gv)
{
    HV* stash = gv_stashpvn("Errno",5,FALSE);

    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { 
	dSP;
	PUTBACK;
	ENTER;
	save_scalar(gv); /* keep the value of $! */
        Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
                         newSVpvn("Errno",5), Nullsv);
	LEAVE;
	SPAGAIN;
	stash = gv_stashpvn("Errno",5,FALSE);
	if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
	    Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
    }
}
コード例 #5
0
ファイル: p5helper.c プロジェクト: niner/Inline-Perl5
GV *p5_look_up_package_method(PerlInterpreter *my_perl, char *module, char *name) {
    PERL_SET_CONTEXT(my_perl);
    {
        HV * const pkg = gv_stashpvn(module, strlen(module), 0);
        GV * const gv = gv_fetchmeth_pvn(pkg, name, strlen(name), -1, SVf_UTF8);
        if (gv && isGV(gv))
            return gv;
        return NULL;
    }
}
コード例 #6
0
ファイル: b_sizeof.c プロジェクト: gfx/p5-B-Size-patched
static void boot_B_Sizeof(void)
{
    HV *stash = gv_stashpvn("B::Sizeof", 9, TRUE);
   (void)newCONSTSUB(stash, "OP", newSViv(sizeof(OP)));
   (void)newCONSTSUB(stash, "PMOP", newSViv(sizeof(PMOP)));
   (void)newCONSTSUB(stash, "UNOP", newSViv(sizeof(UNOP)));
   (void)newCONSTSUB(stash, "BINOP", newSViv(sizeof(BINOP)));
   (void)newCONSTSUB(stash, "LISTOP", newSViv(sizeof(LISTOP)));
   (void)newCONSTSUB(stash, "LOGOP", newSViv(sizeof(LOGOP)));
   (void)newCONSTSUB(stash, "SVOP", newSViv(sizeof(SVOP)));
   (void)newCONSTSUB(stash, "GVOP", newSViv(sizeof(GVOP)));
   (void)newCONSTSUB(stash, "PVOP", newSViv(sizeof(PVOP)));
   (void)newCONSTSUB(stash, "COP", newSViv(sizeof(COP)));
   (void)newCONSTSUB(stash, "LOOP", newSViv(sizeof(LOOP)));
   (void)newCONSTSUB(stash, "SV", newSViv(sizeof(SV)));
   (void)newCONSTSUB(stash, "HV", newSViv(sizeof(HV)));
   (void)newCONSTSUB(stash, "AV", newSViv(sizeof(AV)));
   (void)newCONSTSUB(stash, "NV", newSViv(sizeof(NV)));
   (void)newCONSTSUB(stash, "IV", newSViv(sizeof(IV)));
   (void)newCONSTSUB(stash, "CV", newSViv(sizeof(CV)));
   (void)newCONSTSUB(stash, "GV", newSViv(sizeof(GV)));
   (void)newCONSTSUB(stash, "GP", newSViv(sizeof(GP)));
   (void)newCONSTSUB(stash, "U32", newSViv(sizeof(U32)));
   (void)newCONSTSUB(stash, "U16", newSViv(sizeof(U16)));
   (void)newCONSTSUB(stash, "U8", newSViv(sizeof(U8)));
#ifdef XRV
   (void)newCONSTSUB(stash, "XRV", newSViv(sizeof(XRV)));
#endif
   (void)newCONSTSUB(stash, "XPV", newSViv(sizeof(XPV)));
   (void)newCONSTSUB(stash, "XPVIV", newSViv(sizeof(XPVIV)));
   (void)newCONSTSUB(stash, "XPVUV", newSViv(sizeof(XPVUV)));
   (void)newCONSTSUB(stash, "XPVNV", newSViv(sizeof(XPVNV)));
   (void)newCONSTSUB(stash, "XPVMG", newSViv(sizeof(XPVMG)));
   (void)newCONSTSUB(stash, "XPVLV", newSViv(sizeof(XPVLV)));
   (void)newCONSTSUB(stash, "XPVGV", newSViv(sizeof(XPVGV)));
#ifdef XPVBM
   (void)newCONSTSUB(stash, "XPVBM", newSViv(sizeof(XPVBM)));
#endif
   (void)newCONSTSUB(stash, "XPVFM", newSViv(sizeof(XPVFM)));
   (void)newCONSTSUB(stash, "XPVIO", newSViv(sizeof(XPVIO)));
   (void)newCONSTSUB(stash, "XPVCV", newSViv(sizeof(XPVCV)));
   (void)newCONSTSUB(stash, "XPVAV", newSViv(sizeof(XPVAV)));
   (void)newCONSTSUB(stash, "XPVHV", newSViv(sizeof(XPVHV)));
   (void)newCONSTSUB(stash, "HE", newSViv(sizeof(HE)));
   (void)newCONSTSUB(stash, "HEK", newSViv(sizeof(HEK)));
   (void)newCONSTSUB(stash, "MAGIC", newSViv(sizeof(MAGIC)));
   (void)newCONSTSUB(stash, "REGEXP", newSViv(sizeof(REGEXP)));

}
コード例 #7
0
ファイル: mro.c プロジェクト: Cui-Research-RIT/NucPipeline
/*
=for apidoc mro_method_changed_in

Invalidates method caching on any child classes
of the given stash, so that they might notice
the changes in this one.

Ideally, all instances of C<PL_sub_generation++> in
perl source outside of C<mro.c> should be
replaced by calls to this.

Perl automatically handles most of the common
ways a method might be redefined.  However, there
are a few ways you could change a method in a stash
without the cache code noticing, in which case you
need to call this method afterwards:

1) Directly manipulating the stash HV entries from
XS code.

2) Assigning a reference to a readonly scalar
constant into a stash entry in order to create
a constant subroutine (like constant.pm
does).

This same method is available from pure perl
via, C<mro::method_changed_in(classname)>.

=cut
*/
void
Perl_mro_method_changed_in(pTHX_ HV *stash)
{
    const char * const stashname = HvNAME_get(stash);
    const STRLEN stashname_len = HvNAMELEN_get(stash);

    SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
    HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;

    PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;

    if(!stashname)
        Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");

    /* Inc the package generation, since a local method changed */
    HvMROMETA(stash)->pkg_gen++;

    /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
       invalidate all method caches globally */
    if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
        || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
        PL_sub_generation++;
        return;
    }

    /* else, invalidate the method caches of all child classes,
       but not itself */
    if(isarev) {
	HE* iter;

        hv_iterinit(isarev);
        while((iter = hv_iternext(isarev))) {
	    I32 len;
            const char* const revkey = hv_iterkey(iter, &len);
            HV* const revstash = gv_stashpvn(revkey, len, 0);
            struct mro_meta* mrometa;

            if(!revstash) continue;
            mrometa = HvMROMETA(revstash);
            mrometa->cache_gen++;
            if(mrometa->mro_nextmethod)
                hv_clear(mrometa->mro_nextmethod);
        }
    }
}
コード例 #8
0
ファイル: p5helper.c プロジェクト: niner/Inline-Perl5
SV *p5_call_inherited_package_method(PerlInterpreter *my_perl, char *package, char *base_package, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        SV * retval = NULL;
        HV * stash = gv_stashpvn(package, strlen(package), SVf_UTF8);
        int flags = G_ARRAY | G_EVAL;

        if (stash == NULL) {
            *type = -1; /* signal that a wrapper package needs to be created */
            return NULL;
        }

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        XPUSHs(newSVpv(package, 0));
        push_arguments(sp, len, args);

        {
            GV * const gv = p5_look_up_package_method(my_perl, base_package, name);
            SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
            *count = call_sv(rv, flags);
        }

        SPAGAIN;

        handle_p5_error(err);

        retval = pop_return_values(my_perl, sp, *count, type);

        FREETMPS;
        LEAVE;

        return retval;
    }
}
コード例 #9
0
ファイル: gv.c プロジェクト: fduhia/metamage_1
HV*
Perl_gv_stashpv(pTHX_ const char *name, I32 create)
{
    return gv_stashpvn(name, strlen(name), create);
}
コード例 #10
0
ファイル: gv.c プロジェクト: fduhia/metamage_1
GV *
Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
    AV* av;
    GV* topgv;
    GV* gv;
    GV** gvp;
    CV* cv;

    if (!stash)
	return 0;
    if ((level > 100) || (level < -100))
	Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
	      name, HvNAME(stash));

    DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );

    gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
    if (!gvp)
	topgv = Nullgv;
    else {
	topgv = *gvp;
	if (SvTYPE(topgv) != SVt_PVGV)
	    gv_init(topgv, stash, name, len, TRUE);
	if ((cv = GvCV(topgv))) {
	    /* If genuine method or valid cache entry, use it */
	    if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
		return topgv;
	    /* Stale cached entry: junk it */
	    SvREFCNT_dec(cv);
	    GvCV(topgv) = cv = Nullcv;
	    GvCVGEN(topgv) = 0;
	}
	else if (GvCVGEN(topgv) == PL_sub_generation)
	    return 0;  /* cache indicates sub doesn't exist */
    }

    gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
    av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;

    /* create and re-create @.*::SUPER::ISA on demand */
    if (!av || !SvMAGIC(av)) {
	char* packname = HvNAME(stash);
	STRLEN packlen = strlen(packname);

	if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
	    HV* basestash;

	    packlen -= 7;
	    basestash = gv_stashpvn(packname, packlen, TRUE);
	    gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
	    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
		gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
		if (!gvp || !(gv = *gvp))
		    Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
		if (SvTYPE(gv) != SVt_PVGV)
		    gv_init(gv, stash, "ISA", 3, TRUE);
		SvREFCNT_dec(GvAV(gv));
		GvAV(gv) = (AV*)SvREFCNT_inc(av);
	    }
	}
    }

    if (av) {
	SV** svp = AvARRAY(av);
	/* NOTE: No support for tied ISA */
	I32 items = AvFILLp(av) + 1;
	while (items--) {
	    SV* sv = *svp++;
	    HV* basestash = gv_stashsv(sv, FALSE);
	    if (!basestash) {
		if (ckWARN(WARN_MISC))
		    Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
			SvPVX(sv), HvNAME(stash));
		continue;
	    }
	    gv = gv_fetchmeth(basestash, name, len,
			      (level >= 0) ? level + 1 : level - 1);
	    if (gv)
		goto gotcha;
	}
    }

    /* if at top level, try UNIVERSAL */

    if (level == 0 || level == -1) {
	HV* lastchance;

	if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
	    if ((gv = gv_fetchmeth(lastchance, name, len,
				  (level >= 0) ? level + 1 : level - 1)))
	    {
	  gotcha:
		/*
		 * Cache method in topgv if:
		 *  1. topgv has no synonyms (else inheritance crosses wires)
		 *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
		 */
		if (topgv &&
		    GvREFCNT(topgv) == 1 &&
		    (cv = GvCV(gv)) &&
		    (CvROOT(cv) || CvXSUB(cv)))
		{
		    if ((cv = GvCV(topgv)))
			SvREFCNT_dec(cv);
		    GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
		    GvCVGEN(topgv) = PL_sub_generation;
		}
		return gv;
	    }
	    else if (topgv && GvREFCNT(topgv) == 1) {
		/* cache the fact that the method is not defined */
		GvCVGEN(topgv) = PL_sub_generation;
	    }
	}
    }

    return 0;
}
コード例 #11
0
ファイル: gv.c プロジェクト: gitpan/ponie
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
    register const char *nend;
    const char *nsplit = 0;
    GV* gv;
    HV* ostash = stash;

    if (stash && SvTYPE(stash) < SVt_PVHV)
	stash = Nullhv;

    for (nend = name; *nend; nend++) {
	if (*nend == '\'')
	    nsplit = nend;
	else if (*nend == ':' && *(nend + 1) == ':')
	    nsplit = ++nend;
    }
    if (nsplit) {
	const char *origname = name;
	name = nsplit + 1;
	if (*nsplit == ':')
	    --nsplit;
	if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
	    /* ->SUPER::method should really be looked up in original stash */
	    SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
						  CopSTASHPV(PL_curcop)));
	    /* __PACKAGE__::SUPER stash should be autovivified */
	    stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
	    DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
			 origname, HvNAME(stash), name) );
	}
	else {
            /* don't autovifify if ->NoSuchStash::method */
            stash = gv_stashpvn(origname, nsplit - origname, FALSE);

	    /* however, explicit calls to Pkg::SUPER::method may
	       happen, and may require autovivification to work */
	    if (!stash && (nsplit - origname) >= 7 &&
		strnEQ(nsplit - 7, "::SUPER", 7) &&
		gv_stashpvn(origname, nsplit - origname - 7, FALSE))
	      stash = gv_stashpvn(origname, nsplit - origname, TRUE);
	}
	ostash = stash;
    }

    gv = gv_fetchmeth(stash, name, nend - name, 0);
    if (!gv) {
	if (strEQ(name,"import") || strEQ(name,"unimport"))
	    gv = (GV*)&PL_sv_yes;
	else if (autoload)
	    gv = gv_autoload4(ostash, name, nend - name, TRUE);
    }
    else if (autoload) {
	CV* cv = GvCV(gv);
	if (!CvROOT(cv) && !CvXSUB(cv)) {
	    GV* stubgv;
	    GV* autogv;

	    if (CvANON(cv))
		stubgv = gv;
	    else {
		stubgv = CvGV(cv);
		if (GvCV(stubgv) != cv)		/* orphaned import */
		    stubgv = gv;
	    }
	    autogv = gv_autoload4(GvSTASH(stubgv),
				  GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
	    if (autogv)
		gv = autogv;
	}
    }

    return gv;
}
コード例 #12
0
ファイル: mro.c プロジェクト: Cui-Research-RIT/NucPipeline
/*
=for apidoc mro_isa_changed_in

Takes the necessary steps (cache invalidations, mostly)
when the @ISA of the given package has changed.  Invoked
by the C<setisa> magic, should not need to invoke directly.

=cut
*/
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
    dVAR;
    HV* isarev;
    AV* linear_mro;
    HE* iter;
    SV** svp;
    I32 items;
    bool is_universal;
    struct mro_meta * meta;

    const char * const stashname = HvNAME_get(stash);
    const STRLEN stashname_len = HvNAMELEN_get(stash);

    PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;

    if(!stashname)
        Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");

    /* 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;
	/* This is just acting as a shortcut pointer.  */
	meta->mro_linear_c3 = NULL;
    } else if (meta->mro_linear_c3) {
	/* Only the current MRO is stored, so this owns the data.  */
	SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3));
	meta->mro_linear_c3 = NULL;
    }
    if (meta->isa) {
	SvREFCNT_dec(meta->isa);
	meta->isa = NULL;
    }

    /* Inc the package generation, since our @ISA changed */
    meta->pkg_gen++;

    /* Wipe the global method cache if this package
       is UNIVERSAL or one of its parents */

    svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
    isarev = svp ? MUTABLE_HV(*svp) : NULL;

    if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
        || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
        PL_sub_generation++;
        is_universal = TRUE;
    }
    else { /* Wipe the local method cache otherwise */
        meta->cache_gen++;
	is_universal = FALSE;
    }

    /* wipe next::method cache too */
    if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);

    /* Iterate the isarev (classes that are our children),
       wiping out their linearization, method and isa caches */
    if(isarev) {
        hv_iterinit(isarev);
        while((iter = hv_iternext(isarev))) {
	    I32 len;
            const char* const revkey = hv_iterkey(iter, &len);
            HV* revstash = gv_stashpvn(revkey, len, 0);
            struct mro_meta* revmeta;

            if(!revstash) continue;
            revmeta = HvMROMETA(revstash);
	    if (revmeta->mro_linear_dfs) {
		SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
		revmeta->mro_linear_dfs = NULL;
		/* This is just acting as a shortcut pointer.  */
		revmeta->mro_linear_c3 = NULL;
	    } else if (revmeta->mro_linear_c3) {
		/* Only the current MRO is stored, so this owns the data.  */
		SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3));
		revmeta->mro_linear_c3 = NULL;
	    }
            if(!is_universal)
                revmeta->cache_gen++;
            if(revmeta->mro_nextmethod)
                hv_clear(revmeta->mro_nextmethod);
	    if (revmeta->isa) {
		SvREFCNT_dec(revmeta->isa);
		revmeta->isa = NULL;
	    }
        }
    }

    /* Now iterate our MRO (parents), and do a few things:
         1) instantiate with the "fake" flag if they don't exist
         2) flag them as universal if we are universal
         3) Add everything from our isarev to their isarev
    */

    /* We're starting at the 2nd element, skipping ourselves here */
    linear_mro = mro_get_linear_isa(stash);
    svp = AvARRAY(linear_mro) + 1;
    items = AvFILLp(linear_mro);

    while (items--) {
        SV* const sv = *svp++;
        HV* mroisarev;

        HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);

	/* That fetch should not fail.  But if it had to create a new SV for
	   us, then we can detect it, because it will not be the correct type.
	   Probably faster and cleaner for us to free that scalar [very little
	   code actually executed to free it] and create a new HV than to
	   copy&paste [SIN!] the code from newHV() to allow us to upgrade the
	   new SV from SVt_NULL.  */

        mroisarev = MUTABLE_HV(HeVAL(he));

	if(SvTYPE(mroisarev) != SVt_PVHV) {
	    SvREFCNT_dec(mroisarev);
	    mroisarev = newHV();
	    HeVAL(he) = MUTABLE_SV(mroisarev);
        }

	/* This hash only ever contains PL_sv_yes. Storing it over itself is
	   almost as cheap as calling hv_exists, so on aggregate we expect to
	   save time by not making two calls to the common HV code for the
	   case where it doesn't exist.  */
	   
	(void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);

        if(isarev) {
            hv_iterinit(isarev);
            while((iter = hv_iternext(isarev))) {
                I32 revkeylen;
                char* const revkey = hv_iterkey(iter, &revkeylen);
		(void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
            }
        }
    }
}
コード例 #13
0
ファイル: xsutils.c プロジェクト: bulk88/cperl
/* helper for the default modify handler for builtin attributes */
static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
    SV *attr;
    int nret;

    for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
	STRLEN len;
	const char *name = SvPV_const(attr, len);
	const bool negated = (*name == '-');
        HV *typestash;

	if (negated) {
	    name++;
	    len--;
	}
	switch (SvTYPE(sv)) {
	case SVt_PVCV:
	    switch ((int)len) {
	    case 4:
		if (memEQ(name, "pure", 4)) {
		    if (negated)
			Perl_croak(aTHX_ "Illegal :-pure attribute");
                    CvPURE_on(sv);
		    goto next_attr;
                }
		break;
	    case 5:
		if (memEQ(name, "const", 5)) {
		    if (negated)
			CvCONST_off(sv);
		    else {
#ifndef USE_CPERL
                        const bool warn = (!CvANON(sv) || CvCLONED(sv))
                                        && !CvCONST(sv);
                        CvCONST_on(sv);
                        if (warn)
                            break;
#else
                        CvCONST_on(sv);
#endif
		    }
		    goto next_attr;
		}
		break;
	    case 6:
		switch (name[3]) {
		case 'l':
		    if (memEQ(name, "lvalue", 6)) {
			bool warn =
			    !CvISXSUB(MUTABLE_CV(sv))
			 && CvROOT(MUTABLE_CV(sv))
			 && !CvLVALUE(MUTABLE_CV(sv)) != negated;
			if (negated)
			    CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
			else
			    CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
			if (warn) break;
                        goto next_attr;
		    }
		    break;
		case 'h':
		    if (memEQ(name, "method", 6)) {
			if (negated)
			    CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
			else
			    CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
                        goto next_attr;
		    }
		    break;
		}
		break;
	    default:
		if (len > 10 && memEQ(name, "prototype(", 10)) {
		    SV * proto = newSVpvn(name+10,len-11);
		    HEK *const hek = CvNAME_HEK((CV *)sv);
		    SV *subname;
		    if (name[len-1] != ')')
			Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
		    if (hek)
			subname = sv_2mortal(newSVhek(hek));
		    else
			subname=(SV *)CvGV((const CV *)sv);
		    if (ckWARN(WARN_ILLEGALPROTO))
			Perl_validate_proto(aTHX_ subname, proto, TRUE);
		    Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
		                                    (const GV *)subname,
		                                    name+10,
		                                    len-11,
		                                    SvUTF8(attr));
		    sv_setpvn(MUTABLE_SV(sv), name+10, len-11);
		    if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv));
		    goto next_attr;
		}
		break;
	    }
            if (!negated && (typestash = gv_stashpvn(name, len, SvUTF8(attr)))) {
                CvTYPED_on(sv);
                CvTYPE_set((CV*)sv, typestash);
                continue;
            }
	    break;
	case SVt_IV:
	case SVt_PVIV:
	case SVt_PVMG:
            if (memEQ(name, "unsigned", 8)
                && (SvIOK(sv) || SvUOK(sv)))
            {
                if (negated) /* :-unsigned alias for :signed */
                    SvIsUV_off(sv);
                else
                    SvIsUV_on(sv);
                continue;
            }
            /* fallthru - all other data types */
	default:
            if (memEQ(name, "const", 5)
                && !(SvFLAGS(sv) & SVf_PROTECT))
            {
                if (negated)
                    SvREADONLY_off(sv);
                else
                    SvREADONLY_on(sv);
                continue;
            }
	    if (memEQs(name, len, "shared")) {
                if (negated)
                    Perl_croak(aTHX_ "A variable may not be unshared");
                SvSHARE(sv);
                continue;
	    }
	    break;
	}
	/* anything recognized had a 'continue' above */
	*retlist++ = attr;
	nret++;
    next_attr:
        ;
    }

    return nret;
}