[perl5.git] / xsutils.c

/*    xsutils.c
 *
 *    Copyright (c) 1999-2002, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

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