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

/*    xsutils.c
 *
 *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
 *    by Larry Wall and others
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * "Perilous to us all are the devices of an art deeper than we possess
 * ourselves." --Gandalf
 */


#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 9:
		if (strEQ(name, "assertion")) {
		    if (negated)
			CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
		    else
			CvFLAGS((CV*)sv) |= CVf_ASSERTION;
		    continue;
		}
		break;
	    case 6:
		switch (*name) {
		case 'a':
		    if (strEQ(name, "assertion")) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
			else
			    CvFLAGS((CV*)sv) |= CVf_ASSERTION;
			continue;
		    }
		    break;
		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;
		}
		break;
	    }
	    break;
	default:
	    switch ((int)len) {
	    case 6:
		switch (*name) {
		case 's':
		    if (strEQ(name, "shared")) {
			if (negated)
			    Perl_croak(aTHX_ "A variable may not be unshared");
			SvSHARE(sv);
                        continue;
                    }
		    break;
		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)));
	if (cvflags & CVf_ASSERTION)
	    XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
	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;
    dXSTARG;

    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));
    }

    SvSETMAGIC(TARG);
    XSRETURN(1);
}

XS(XS_attributes_reftype)
{
    dXSARGS;
    SV *rv, *sv;
    dXSTARG;

    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));
    SvSETMAGIC(TARG);

    XSRETURN(1);
}

XS(XS_attributes__warn_reserved)
{
    dXSARGS;

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

    EXTEND(SP,1);
    ST(0) = boolSV(ckWARN(WARN_RESERVED));

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