[p5sagit/p5-mst-13.2.git] / xsutils.c

#include "EXTERN.h"
#define PERL_IN_XSUTILS_C
#include "perl.h"

/*
 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
 */

/* package attributes; */
void XS_attributes__warn_reserved(pTHX_ CV *cv);
void XS_attributes_reftype(pTHX_ CV *cv);
void XS_attributes__modify_attrs(pTHX_ CV *cv);
void XS_attributes__guess_stash(pTHX_ CV *cv);
void XS_attributes__fetch_attrs(pTHX_ CV *cv);
void XS_attributes_bootstrap(pTHX_ CV *cv);


/*
 * Note that only ${pkg}::bootstrap definitions should go here.
 * This helps keep down the start-up time, which is especially
 * relevant for users who don't invoke any features which are
 * (partially) implemented here.
 *
 * The various bootstrap definitions can take care of doing
 * package-specific newXS() calls.  Since the layout of the
 * bundled *.pm files is in a version-specific directory,
 * version checks in these bootstrap calls are optional.
 */

void
Perl_boot_core_xsutils(pTHX)
{
    char *file = __FILE__;

    newXS("attributes::bootstrap",	XS_attributes_bootstrap,	file);
}

#include "XSUB.h"

static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
    SV *attr;
    char *name;
    STRLEN len;
    bool negated;
    int nret;

    for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
	name = SvPV(attr, len);
	if ((negated = (*name == '-'))) {
	    name++;
	    len--;
	}
	switch (SvTYPE(sv)) {
	case SVt_PVCV:
	    switch ((int)len) {
	    case 6:
		switch (*name) {
		case 'l':
#ifdef CVf_LVALUE
		    if (strEQ(name, "lvalue")) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
			else
			    CvFLAGS((CV*)sv) |= CVf_LVALUE;
			continue;
		    }
#endif /* defined CVf_LVALUE */
		    if (strEQ(name, "locked")) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
			else
			    CvFLAGS((CV*)sv) |= CVf_LOCKED;
			continue;
		    }
		    break;
		case 'm':
		    if (strEQ(name, "method")) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_METHOD;
			else
			    CvFLAGS((CV*)sv) |= CVf_METHOD;
			continue;
		    }
		    break;
		case 'u':
		    if (strEQ(name, "unique")) {
			if (negated)
			    GvUNIQUE_off(CvGV((CV*)sv));
			else
			    GvUNIQUE_on(CvGV((CV*)sv));
			continue;
		    }
		    break;
		}
		break;
	    }
	    break;
	default:
	    switch ((int)len) {
	    case 6:
		switch (*name) {
		case 'u':
		    if (strEQ(name, "unique")) {
			if (SvTYPE(sv) == SVt_PVGV) {
			    if (negated)
				GvUNIQUE_off(sv);
			    else
				GvUNIQUE_on(sv);
			}
			/* Hope this came from toke.c if not a GV. */
                        continue;
                    }
                }
            }
	    break;
	}
	/* anything recognized had a 'continue' above */
	*retlist++ = attr;
	nret++;
    }

    return nret;
}


/* package attributes; */

XS(XS_attributes_bootstrap)
{
    dXSARGS;
    char *file = __FILE__;

    if( items > 1 )
        Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");

    newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
    newXS("attributes::_modify_attrs",	XS_attributes__modify_attrs,	file);
    newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
    newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
    newXSproto("attributes::reftype",	XS_attributes_reftype,	file, "$");

    XSRETURN(0);
}

XS(XS_attributes__modify_attrs)
{
    dXSARGS;
    SV *rv, *sv;

    if (items < 1) {
usage:
	Perl_croak(aTHX_
		   "Usage: attributes::_modify_attrs $reference, @attributes");
    }

    rv = ST(0);
    if (!(SvOK(rv) && SvROK(rv)))
	goto usage;
    sv = SvRV(rv);
    if (items > 1)
	XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));

    XSRETURN(0);
}

XS(XS_attributes__fetch_attrs)
{
    dXSARGS;
    SV *rv, *sv;
    cv_flags_t cvflags;

    if (items != 1) {
usage:
	Perl_croak(aTHX_
		   "Usage: attributes::_fetch_attrs $reference");
    }

    rv = ST(0);
    SP -= items;
    if (!(SvOK(rv) && SvROK(rv)))
	goto usage;
    sv = SvRV(rv);

    switch (SvTYPE(sv)) {
    case SVt_PVCV:
	cvflags = CvFLAGS((CV*)sv);
	if (cvflags & CVf_LOCKED)
	    XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
#ifdef CVf_LVALUE
	if (cvflags & CVf_LVALUE)
	    XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
#endif
	if (cvflags & CVf_METHOD)
	    XPUSHs(sv_2mortal(newSVpvn("method", 6)));
        if (GvUNIQUE(CvGV((CV*)sv)))
	    XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
	break;
    case SVt_PVGV:
	if (GvUNIQUE(sv))
	    XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
	break;
    default:
	break;
    }

    PUTBACK;
}

XS(XS_attributes__guess_stash)
{
    dXSARGS;
    SV *rv, *sv;
#ifdef dXSTARGET
    dXSTARGET;
#else
    SV * TARG = sv_newmortal();
#endif

    if (items != 1) {
usage:
	Perl_croak(aTHX_
		   "Usage: attributes::_guess_stash $reference");
    }

    rv = ST(0);
    ST(0) = TARG;
    if (!(SvOK(rv) && SvROK(rv)))
	goto usage;
    sv = SvRV(rv);

    if (SvOBJECT(sv))
	sv_setpv(TARG, HvNAME(SvSTASH(sv)));
#if 0	/* this was probably a bad idea */
    else if (SvPADMY(sv))
	sv_setsv(TARG, &PL_sv_no);	/* unblessed lexical */
#endif
    else {
	HV *stash = Nullhv;
	switch (SvTYPE(sv)) {
	case SVt_PVCV:
	    if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
		stash = GvSTASH(CvGV(sv));
	    else if (/* !CvANON(sv) && */ CvSTASH(sv))
		stash = CvSTASH(sv);
	    break;
	case SVt_PVMG:
	    if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
		break;
	    /*FALLTHROUGH*/
	case SVt_PVGV:
	    if (GvGP(sv) && GvESTASH((GV*)sv))
		stash = GvESTASH((GV*)sv);
	    break;
	default:
	    break;
	}
	if (stash)
	    sv_setpv(TARG, HvNAME(stash));
    }

#ifdef dXSTARGET
    SvSETMAGIC(TARG);
#endif
    XSRETURN(1);
}

XS(XS_attributes_reftype)
{
    dXSARGS;
    SV *rv, *sv;
#ifdef dXSTARGET
    dXSTARGET;
#else
    SV * TARG = sv_newmortal();
#endif

    if (items != 1) {
usage:
	Perl_croak(aTHX_
		   "Usage: attributes::reftype $reference");
    }

    rv = ST(0);
    ST(0) = TARG;
    if (SvGMAGICAL(rv))
	mg_get(rv);
    if (!(SvOK(rv) && SvROK(rv)))
	goto usage;
    sv = SvRV(rv);
    sv_setpv(TARG, sv_reftype(sv, 0));
#ifdef dXSTARGET
    SvSETMAGIC(TARG);
#endif

    XSRETURN(1);
}

XS(XS_attributes__warn_reserved)
{
    dXSARGS;
#ifdef dXSTARGET
    dXSTARGET;
#else
    SV * TARG = sv_newmortal();
#endif

    if (items != 0) {
	Perl_croak(aTHX_
		   "Usage: attributes::_warn_reserved ()");
    }

    EXTEND(SP,1);
    ST(0) = TARG;
    sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
#ifdef dXSTARGET
    SvSETMAGIC(TARG);
#endif

    XSRETURN(1);
}
Commit	Line	Data
09bef843	1	#include "EXTERN.h"
	2	#define PERL_IN_XSUTILS_C
	3	#include "perl.h"
	4
	5	/*
	6	* Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
	7	*/
	8
349fd7b7	9	/* package attributes; */
acfe0abc	10	void XS_attributes__warn_reserved(pTHX_ CV *cv);
	11	void XS_attributes_reftype(pTHX_ CV *cv);
	12	void XS_attributes__modify_attrs(pTHX_ CV *cv);
	13	void XS_attributes__guess_stash(pTHX_ CV *cv);
	14	void XS_attributes__fetch_attrs(pTHX_ CV *cv);
	15	void XS_attributes_bootstrap(pTHX_ CV *cv);
349fd7b7	16
	17
	18	/*
	19	* Note that only ${pkg}::bootstrap definitions should go here.
	20	* This helps keep down the start-up time, which is especially
	21	* relevant for users who don't invoke any features which are
	22	* (partially) implemented here.
	23	*
	24	* The various bootstrap definitions can take care of doing
	25	* package-specific newXS() calls. Since the layout of the
6a34af38	26	* bundled *.pm files is in a version-specific directory,
349fd7b7	27	* version checks in these bootstrap calls are optional.
	28	*/
	29
	30	void
	31	Perl_boot_core_xsutils(pTHX)
	32	{
	33	char *file = __FILE__;
	34
	35	newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
	36	}
	37
349fd7b7	38	#include "XSUB.h"
	39
	40	static int
acfe0abc	41	modify_SV_attributes(pTHX_ SV sv, SV retlist, SV *attrlist, int numattrs)
09bef843	42	{
	43	SV *attr;
	44	char *name;
	45	STRLEN len;
	46	bool negated;
	47	int nret;
	48
	49	for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
	50	name = SvPV(attr, len);
155aba94	51	if ((negated = (*name == '-'))) {
09bef843	52	name++;
	53	len--;
	54	}
	55	switch (SvTYPE(sv)) {
	56	case SVt_PVCV:
	57	switch ((int)len) {
	58	case 6:
	59	switch (*name) {
	60	case 'l':
	61	#ifdef CVf_LVALUE
	62	if (strEQ(name, "lvalue")) {
	63	if (negated)
	64	CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
	65	else
	66	CvFLAGS((CV*)sv) \|= CVf_LVALUE;
	67	continue;
	68	}
	69	#endif /* defined CVf_LVALUE */
	70	if (strEQ(name, "locked")) {
	71	if (negated)
	72	CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
	73	else
	74	CvFLAGS((CV*)sv) \|= CVf_LOCKED;
	75	continue;
	76	}
	77	break;
	78	case 'm':
	79	if (strEQ(name, "method")) {
	80	if (negated)
	81	CvFLAGS((CV*)sv) &= ~CVf_METHOD;
	82	else
	83	CvFLAGS((CV*)sv) \|= CVf_METHOD;
	84	continue;
	85	}
	86	break;
95f0a2f1	87	case 'u':
95f0a2f1	88	if (strEQ(name, "unique")) {
0256094b	89	if (negated)
7fb37951	90	GvUNIQUE_off(CvGV((CV*)sv));
0256094b	91	else
7fb37951	92	GvUNIQUE_on(CvGV((CV*)sv));
0256094b	93	continue;
	94	}
	95	break;
09bef843	96	}
	97	break;
	98	}
	99	break;
	100	default:
0256094b	101	switch ((int)len) {
95f0a2f1	102	case 6:
0256094b	103	switch (*name) {
95f0a2f1	104	case 'u':
	105	if (strEQ(name, "unique")) {
	106	if (SvTYPE(sv) == SVt_PVGV) {
	107	if (negated)
	108	GvUNIQUE_off(sv);
	109	else
	110	GvUNIQUE_on(sv);
	111	}
	112	/* Hope this came from toke.c if not a GV. */
0256094b	113	continue;
	114	}
	115	}
	116	}
09bef843	117	break;
	118	}
	119	/* anything recognized had a 'continue' above */
	120	*retlist++ = attr;
	121	nret++;
	122	}
	123
	124	return nret;
	125	}
	126
	127
09bef843	128
	129	/* package attributes; */
	130
	131	XS(XS_attributes_bootstrap)
	132	{
	133	dXSARGS;
	134	char *file = __FILE__;
	135
592f5969	136	if( items > 1 )
592f5969	137	Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
b7953727	138
09bef843	139	newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
	140	newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
	141	newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
	142	newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
	143	newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
	144
	145	XSRETURN(0);
	146	}
	147
	148	XS(XS_attributes__modify_attrs)
	149	{
	150	dXSARGS;
	151	SV rv, sv;
	152
	153	if (items < 1) {
	154	usage:
	155	Perl_croak(aTHX_
	156	"Usage: attributes::_modify_attrs $reference, @attributes");
	157	}
	158
	159	rv = ST(0);
	160	if (!(SvOK(rv) && SvROK(rv)))
	161	goto usage;
	162	sv = SvRV(rv);
	163	if (items > 1)
acfe0abc	164	XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843	165
	166	XSRETURN(0);
	167	}
	168
	169	XS(XS_attributes__fetch_attrs)
	170	{
	171	dXSARGS;
	172	SV rv, sv;
	173	cv_flags_t cvflags;
	174
	175	if (items != 1) {
	176	usage:
	177	Perl_croak(aTHX_
	178	"Usage: attributes::_fetch_attrs $reference");
	179	}
	180
	181	rv = ST(0);
	182	SP -= items;
	183	if (!(SvOK(rv) && SvROK(rv)))
	184	goto usage;
	185	sv = SvRV(rv);
	186
	187	switch (SvTYPE(sv)) {
	188	case SVt_PVCV:
	189	cvflags = CvFLAGS((CV*)sv);
	190	if (cvflags & CVf_LOCKED)
	191	XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
	192	#ifdef CVf_LVALUE
	193	if (cvflags & CVf_LVALUE)
	194	XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
	195	#endif
	196	if (cvflags & CVf_METHOD)
	197	XPUSHs(sv_2mortal(newSVpvn("method", 6)));
7fb37951	198	if (GvUNIQUE(CvGV((CV*)sv)))
95f0a2f1	199	XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
	200	break;
	201	case SVt_PVGV:
	202	if (GvUNIQUE(sv))
	203	XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
09bef843	204	break;
	205	default:
	206	break;
	207	}
	208
	209	PUTBACK;
	210	}
	211
	212	XS(XS_attributes__guess_stash)
	213	{
	214	dXSARGS;
	215	SV rv, sv;
	216	#ifdef dXSTARGET
	217	dXSTARGET;
	218	#else
	219	SV * TARG = sv_newmortal();
	220	#endif
	221
	222	if (items != 1) {
	223	usage:
	224	Perl_croak(aTHX_
	225	"Usage: attributes::_guess_stash $reference");
	226	}
	227
	228	rv = ST(0);
	229	ST(0) = TARG;
	230	if (!(SvOK(rv) && SvROK(rv)))
	231	goto usage;
	232	sv = SvRV(rv);
	233
	234	if (SvOBJECT(sv))
	235	sv_setpv(TARG, HvNAME(SvSTASH(sv)));
	236	#if 0 /* this was probably a bad idea */
	237	else if (SvPADMY(sv))
	238	sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
	239	#endif
	240	else {
	241	HV *stash = Nullhv;
	242	switch (SvTYPE(sv)) {
	243	case SVt_PVCV:
6676db26	244	if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843	245	stash = GvSTASH(CvGV(sv));
6676db26	246	else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843	247	stash = CvSTASH(sv);
	248	break;
	249	case SVt_PVMG:
14befaf4	250	if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
09bef843	251	break;
	252	/FALLTHROUGH/
	253	case SVt_PVGV:
6676db26	254	if (GvGP(sv) && GvESTASH((GV*)sv))
09bef843	255	stash = GvESTASH((GV*)sv);
	256	break;
	257	default:
	258	break;
	259	}
	260	if (stash)
	261	sv_setpv(TARG, HvNAME(stash));
	262	}
	263
	264	#ifdef dXSTARGET
	265	SvSETMAGIC(TARG);
	266	#endif
	267	XSRETURN(1);
	268	}
	269
	270	XS(XS_attributes_reftype)
	271	{
	272	dXSARGS;
	273	SV rv, sv;
	274	#ifdef dXSTARGET
	275	dXSTARGET;
	276	#else
	277	SV * TARG = sv_newmortal();
	278	#endif
	279
	280	if (items != 1) {
	281	usage:
	282	Perl_croak(aTHX_
	283	"Usage: attributes::reftype $reference");
	284	}
	285
	286	rv = ST(0);
	287	ST(0) = TARG;
4694d0ea	288	if (SvGMAGICAL(rv))
4694d0ea	289	mg_get(rv);
121e869f	290	if (!(SvOK(rv) && SvROK(rv)))
09bef843	291	goto usage;
	292	sv = SvRV(rv);
	293	sv_setpv(TARG, sv_reftype(sv, 0));
	294	#ifdef dXSTARGET
	295	SvSETMAGIC(TARG);
	296	#endif
	297
	298	XSRETURN(1);
	299	}
	300
	301	XS(XS_attributes__warn_reserved)
	302	{
	303	dXSARGS;
09bef843	304	#ifdef dXSTARGET
	305	dXSTARGET;
	306	#else
	307	SV * TARG = sv_newmortal();
	308	#endif
	309
	310	if (items != 0) {
	311	Perl_croak(aTHX_
	312	"Usage: attributes::_warn_reserved ()");
	313	}
	314
	315	EXTEND(SP,1);
	316	ST(0) = TARG;
	317	sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
	318	#ifdef dXSTARGET
	319	SvSETMAGIC(TARG);
	320	#endif
	321
	322	XSRETURN(1);
	323	}
	324