[perl5.git] / xsutils.c

/*    xsutils.c
 *
 *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
 *    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; */
PERL_XS_EXPORT_C void XS_attributes__warn_reserved(pTHX_ CV *cv);
PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
PERL_XS_EXPORT_C 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)
{
    const 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)
{
    dVAR;
    SV *attr;
    int nret;

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

	if (negated) {
	    name++;
	    len--;
	}
	switch (SvTYPE(sv)) {
	case SVt_PVCV:
	    switch ((int)len) {
#ifdef CVf_ASSERTION
	    case 9:
		if (memEQ(name, "assertion", 9)) {
		    if (negated)
			CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
		    else
			CvFLAGS((CV*)sv) |= CVf_ASSERTION;
		    continue;
		}
		break;
#endif
	    case 6:
		switch (name[3]) {
		case 'l':
#ifdef CVf_LVALUE
		    if (memEQ(name, "lvalue", 6)) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
			else
			    CvFLAGS((CV*)sv) |= CVf_LVALUE;
			continue;
		    }
		    break;
		case 'k':
#endif /* defined CVf_LVALUE */
		    if (memEQ(name, "locked", 6)) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
			else
			    CvFLAGS((CV*)sv) |= CVf_LOCKED;
			continue;
		    }
		    break;
		case 'h':
		    if (memEQ(name, "method", 6)) {
			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[5]) {
		case 'd':
		    if (memEQ(name, "share", 5)) {
			if (negated)
			    Perl_croak(aTHX_ "A variable may not be unshared");
			SvSHARE(sv);
                        continue;
                    }
		    break;
		case 'e':
		    if (memEQ(name, "uniqu", 5)) {
			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)
{
    dVAR;
    dXSARGS;
    const 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)
{
    dVAR;
    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)
{
    dVAR;
    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(newSVpvs("locked")));
#ifdef CVf_LVALUE
	if (cvflags & CVf_LVALUE)
	    XPUSHs(sv_2mortal(newSVpvs("lvalue")));
#endif
	if (cvflags & CVf_METHOD)
	    XPUSHs(sv_2mortal(newSVpvs("method")));
        if (GvUNIQUE(CvGV((CV*)sv)))
	    XPUSHs(sv_2mortal(newSVpvs("unique")));
	if (cvflags & CVf_ASSERTION)
	    XPUSHs(sv_2mortal(newSVpvs("assertion")));
	break;
    case SVt_PVGV:
	if (GvUNIQUE(sv))
	    XPUSHs(sv_2mortal(newSVpvs("unique")));
	break;
    default:
	break;
    }

    PUTBACK;
}

XS(XS_attributes__guess_stash)
{
    dVAR;
    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_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
#if 0	/* this was probably a bad idea */
    else if (SvPADMY(sv))
	sv_setsv(TARG, &PL_sv_no);	/* unblessed lexical */
#endif
    else {
	const HV *stash = NULL;
	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_PVGV:
	    if (GvGP(sv) && GvESTASH((GV*)sv))
		stash = GvESTASH((GV*)sv);
	    break;
	default:
	    break;
	}
	if (stash)
	    sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
    }

    SvSETMAGIC(TARG);
    XSRETURN(1);
}

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

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

    rv = ST(0);
    ST(0) = TARG;
    SvGETMAGIC(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)
{
    dVAR;
    dXSARGS;

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

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

    XSRETURN(1);
}

/*
 * Local variables:
 * c-indentation-style: bsd
 * c-basic-offset: 4
 * indent-tabs-mode: t
 * End:
 *
 * ex: set ts=8 sts=4 sw=4 noet:
 */
Commit	Line	Data
d6376244 JH	1	/* xsutils.c
d6376244 JH	2	*
acde74e1	3	* Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
371fce9b	4	* by Larry Wall and others
d6376244 JH	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 AT	11	/*
	12	* "Perilous to us all are the devices of an art deeper than we possess
	13	* ourselves." --Gandalf
	14	*/
	15
	16
09bef843 SB	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; */
27da23d5 JH	26	PERL_XS_EXPORT_C void XS_attributes__warn_reserved(pTHX_ CV *cv);
	27	PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
	28	PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
	29	PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
	30	PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
	31	PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
349fd7b7 GS	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 GS	43	* version checks in these bootstrap calls are optional.
	44	*/
	45
	46	void
	47	Perl_boot_core_xsutils(pTHX)
	48	{
e1ec3a88	49	const char file[] = __FILE__;
349fd7b7 GS	50
	51	newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
	52	}
	53
349fd7b7 GS	54	#include "XSUB.h"
	55
	56	static int
acfe0abc	57	modify_SV_attributes(pTHX_ SV sv, SV retlist, SV *attrlist, int numattrs)
09bef843	58	{
97aff369	59	dVAR;
09bef843	60	SV *attr;
09bef843 SB	61	int nret;
	62
	63	for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
4373e329	64	STRLEN len;
cfd0369c	65	const char *name = SvPV_const(attr, len);
4373e329 AL	66	const bool negated = (*name == '-');
	67
	68	if (negated) {
09bef843 SB	69	name++;
	70	len--;
	71	}
	72	switch (SvTYPE(sv)) {
	73	case SVt_PVCV:
	74	switch ((int)len) {
77c9267e	75	#ifdef CVf_ASSERTION
42262798	76	case 9:
8cad210e	77	if (memEQ(name, "assertion", 9)) {
42262798 NC	78	if (negated)
	79	CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
	80	else
	81	CvFLAGS((CV*)sv) \|= CVf_ASSERTION;
	82	continue;
	83	}
	84	break;
77c9267e	85	#endif
09bef843	86	case 6:
8cad210e	87	switch (name[3]) {
09bef843 SB	88	case 'l':
09bef843 SB	89	#ifdef CVf_LVALUE
8cad210e	90	if (memEQ(name, "lvalue", 6)) {
09bef843 SB	91	if (negated)
	92	CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
	93	else
	94	CvFLAGS((CV*)sv) \|= CVf_LVALUE;
	95	continue;
	96	}
8cad210e NC	97	break;
8cad210e NC	98	case 'k':
09bef843	99	#endif /* defined CVf_LVALUE */
8cad210e	100	if (memEQ(name, "locked", 6)) {
09bef843 SB	101	if (negated)
	102	CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
	103	else
	104	CvFLAGS((CV*)sv) \|= CVf_LOCKED;
	105	continue;
	106	}
	107	break;
8cad210e NC	108	case 'h':
8cad210e NC	109	if (memEQ(name, "method", 6)) {
09bef843 SB	110	if (negated)
	111	CvFLAGS((CV*)sv) &= ~CVf_METHOD;
	112	else
	113	CvFLAGS((CV*)sv) \|= CVf_METHOD;
	114	continue;
	115	}
	116	break;
	117	}
	118	break;
	119	}
	120	break;
	121	default:
0256094b	122	switch ((int)len) {
95f0a2f1	123	case 6:
8cad210e NC	124	switch (name[5]) {
	125	case 'd':
	126	if (memEQ(name, "share", 5)) {
13c1b207 DM	127	if (negated)
	128	Perl_croak(aTHX_ "A variable may not be unshared");
	129	SvSHARE(sv);
	130	continue;
	131	}
	132	break;
8cad210e NC	133	case 'e':
8cad210e NC	134	if (memEQ(name, "uniqu", 5)) {
95f0a2f1	135	if (SvTYPE(sv) == SVt_PVGV) {
44f8325f	136	if (negated) {
95f0a2f1	137	GvUNIQUE_off(sv);
44f8325f	138	} else {
95f0a2f1	139	GvUNIQUE_on(sv);
44f8325f	140	}
95f0a2f1 SB	141	}
95f0a2f1 SB	142	/* Hope this came from toke.c if not a GV. */
0256094b DM	143	continue;
	144	}
	145	}
	146	}
09bef843 SB	147	break;
	148	}
	149	/* anything recognized had a 'continue' above */
	150	*retlist++ = attr;
	151	nret++;
	152	}
	153
	154	return nret;
	155	}
	156
	157
09bef843 SB	158
	159	/* package attributes; */
	160
	161	XS(XS_attributes_bootstrap)
	162	{
97aff369	163	dVAR;
09bef843	164	dXSARGS;
e1ec3a88	165	const char file[] = __FILE__;
09bef843	166
592f5969 MS	167	if( items > 1 )
592f5969 MS	168	Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
b7953727	169
09bef843 SB	170	newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
	171	newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
	172	newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
	173	newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
	174	newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
	175
	176	XSRETURN(0);
	177	}
	178
	179	XS(XS_attributes__modify_attrs)
	180	{
97aff369	181	dVAR;
09bef843 SB	182	dXSARGS;
	183	SV rv, sv;
	184
	185	if (items < 1) {
	186	usage:
	187	Perl_croak(aTHX_
	188	"Usage: attributes::_modify_attrs $reference, @attributes");
	189	}
	190
	191	rv = ST(0);
	192	if (!(SvOK(rv) && SvROK(rv)))
	193	goto usage;
	194	sv = SvRV(rv);
	195	if (items > 1)
acfe0abc	196	XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843 SB	197
	198	XSRETURN(0);
	199	}
	200
	201	XS(XS_attributes__fetch_attrs)
	202	{
97aff369	203	dVAR;
09bef843 SB	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)
396482e1	224	XPUSHs(sv_2mortal(newSVpvs("locked")));
09bef843 SB	225	#ifdef CVf_LVALUE
09bef843 SB	226	if (cvflags & CVf_LVALUE)
396482e1	227	XPUSHs(sv_2mortal(newSVpvs("lvalue")));
09bef843 SB	228	#endif
09bef843 SB	229	if (cvflags & CVf_METHOD)
396482e1	230	XPUSHs(sv_2mortal(newSVpvs("method")));
7fb37951	231	if (GvUNIQUE(CvGV((CV*)sv)))
396482e1	232	XPUSHs(sv_2mortal(newSVpvs("unique")));
06492da6	233	if (cvflags & CVf_ASSERTION)
396482e1	234	XPUSHs(sv_2mortal(newSVpvs("assertion")));
95f0a2f1 SB	235	break;
	236	case SVt_PVGV:
	237	if (GvUNIQUE(sv))
396482e1	238	XPUSHs(sv_2mortal(newSVpvs("unique")));
09bef843 SB	239	break;
	240	default:
	241	break;
	242	}
	243
	244	PUTBACK;
	245	}
	246
	247	XS(XS_attributes__guess_stash)
	248	{
97aff369	249	dVAR;
09bef843 SB	250	dXSARGS;
09bef843 SB	251	SV rv, sv;
d277572a	252	dXSTARG;
09bef843 SB	253
	254	if (items != 1) {
	255	usage:
	256	Perl_croak(aTHX_
	257	"Usage: attributes::_guess_stash $reference");
	258	}
	259
	260	rv = ST(0);
	261	ST(0) = TARG;
	262	if (!(SvOK(rv) && SvROK(rv)))
	263	goto usage;
	264	sv = SvRV(rv);
	265
	266	if (SvOBJECT(sv))
7423f6db	267	sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
09bef843 SB	268	#if 0 /* this was probably a bad idea */
	269	else if (SvPADMY(sv))
	270	sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
	271	#endif
	272	else {
5c284bb0	273	const HV *stash = NULL;
09bef843 SB	274	switch (SvTYPE(sv)) {
09bef843 SB	275	case SVt_PVCV:
6676db26	276	if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843	277	stash = GvSTASH(CvGV(sv));
6676db26	278	else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843 SB	279	stash = CvSTASH(sv);
09bef843 SB	280	break;
09bef843	281	case SVt_PVGV:
6676db26	282	if (GvGP(sv) && GvESTASH((GV*)sv))
09bef843 SB	283	stash = GvESTASH((GV*)sv);
	284	break;
	285	default:
	286	break;
	287	}
	288	if (stash)
7423f6db	289	sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
09bef843 SB	290	}
09bef843 SB	291
09bef843	292	SvSETMAGIC(TARG);
09bef843 SB	293	XSRETURN(1);
	294	}
	295
	296	XS(XS_attributes_reftype)
	297	{
97aff369	298	dVAR;
09bef843 SB	299	dXSARGS;
09bef843 SB	300	SV rv, sv;
d277572a	301	dXSTARG;
09bef843 SB	302
	303	if (items != 1) {
	304	usage:
	305	Perl_croak(aTHX_
	306	"Usage: attributes::reftype $reference");
	307	}
	308
	309	rv = ST(0);
	310	ST(0) = TARG;
5b295bef	311	SvGETMAGIC(rv);
121e869f	312	if (!(SvOK(rv) && SvROK(rv)))
09bef843 SB	313	goto usage;
	314	sv = SvRV(rv);
	315	sv_setpv(TARG, sv_reftype(sv, 0));
09bef843	316	SvSETMAGIC(TARG);
09bef843 SB	317
	318	XSRETURN(1);
	319	}
	320
	321	XS(XS_attributes__warn_reserved)
	322	{
97aff369	323	dVAR;
09bef843	324	dXSARGS;
09bef843 SB	325
	326	if (items != 0) {
	327	Perl_croak(aTHX_
	328	"Usage: attributes::_warn_reserved ()");
	329	}
	330
	331	EXTEND(SP,1);
0006dff7	332	ST(0) = boolSV(ckWARN(WARN_RESERVED));
09bef843 SB	333
	334	XSRETURN(1);
	335	}
	336
66610fdd RGS	337	/*
	338	* Local variables:
	339	* c-indentation-style: bsd
	340	* c-basic-offset: 4
	341	* indent-tabs-mode: t
	342	* End:
	343	*
37442d52 RGS	344	* ex: set ts=8 sts=4 sw=4 noet:
37442d52 RGS	345	*/