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

/*    xsutils.c
 *
 *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
 *    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_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.
 */

static const char file[] = __FILE__;

void
Perl_boot_core_xsutils(pTHX)
{
    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) {
	    case 6:
		switch (name[3]) {
#ifdef CVf_LVALUE
		case 'l':
		    if (memEQ(name, "lvalue", 6)) {
			if (negated)
			    CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
			else
			    CvFLAGS((CV*)sv) |= CVf_LVALUE;
			continue;
		    }
		    break;
#endif
		case 'k':
		    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 (isGV_with_GP(sv)) {
			    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;

    if( items > 1 )
	croak_xs_usage(cv, "$module");

    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:
	croak_xs_usage(cv, "@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:
	croak_xs_usage(cv, "$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(newSVpvs_flags("locked", SVs_TEMP));
#ifdef CVf_LVALUE
	if (cvflags & CVf_LVALUE)
	    XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
#endif
	if (cvflags & CVf_METHOD)
	    XPUSHs(newSVpvs_flags("method", SVs_TEMP));
        if (GvUNIQUE(CvGV((CV*)sv)))
	    XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
	break;
    case SVt_PVGV:
	if (isGV_with_GP(sv) && GvUNIQUE(sv))
	    XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
	break;
    default:
	break;
    }

    PUTBACK;
}

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

    if (items != 1) {
usage:
	croak_xs_usage(cv, "$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 (isGV_with_GP(sv) && 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:
	croak_xs_usage(cv, "$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);
}

/*
 * 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	1	/* xsutils.c
d6376244	2	*
663f364b	3	* Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
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; */
27da23d5	26	PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
	27	PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
	28	PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
	29	PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
	30	PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
349fd7b7	31
	32
	33	/*
	34	* Note that only ${pkg}::bootstrap definitions should go here.
	35	* This helps keep down the start-up time, which is especially
	36	* relevant for users who don't invoke any features which are
	37	* (partially) implemented here.
	38	*
	39	* The various bootstrap definitions can take care of doing
	40	* package-specific newXS() calls. Since the layout of the
6a34af38	41	* bundled *.pm files is in a version-specific directory,
349fd7b7	42	* version checks in these bootstrap calls are optional.
	43	*/
	44
a4c98449	45	static const char file[] = __FILE__;
a4c98449	46
349fd7b7	47	void
	48	Perl_boot_core_xsutils(pTHX)
	49	{
349fd7b7	50	newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
	51	}
	52
349fd7b7	53	#include "XSUB.h"
	54
	55	static int
acfe0abc	56	modify_SV_attributes(pTHX_ SV sv, SV retlist, SV *attrlist, int numattrs)
09bef843	57	{
97aff369	58	dVAR;
09bef843	59	SV *attr;
09bef843	60	int nret;
	61
	62	for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
4373e329	63	STRLEN len;
cfd0369c	64	const char *name = SvPV_const(attr, len);
4373e329	65	const bool negated = (*name == '-');
	66
	67	if (negated) {
09bef843	68	name++;
	69	len--;
	70	}
	71	switch (SvTYPE(sv)) {
	72	case SVt_PVCV:
	73	switch ((int)len) {
	74	case 6:
8cad210e	75	switch (name[3]) {
09bef843	76	#ifdef CVf_LVALUE
d5adc3a1	77	case 'l':
8cad210e	78	if (memEQ(name, "lvalue", 6)) {
09bef843	79	if (negated)
	80	CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
	81	else
	82	CvFLAGS((CV*)sv) \|= CVf_LVALUE;
	83	continue;
	84	}
8cad210e	85	break;
d5adc3a1	86	#endif
8cad210e	87	case 'k':
8cad210e	88	if (memEQ(name, "locked", 6)) {
09bef843	89	if (negated)
	90	CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
	91	else
	92	CvFLAGS((CV*)sv) \|= CVf_LOCKED;
	93	continue;
	94	}
	95	break;
8cad210e	96	case 'h':
8cad210e	97	if (memEQ(name, "method", 6)) {
09bef843	98	if (negated)
	99	CvFLAGS((CV*)sv) &= ~CVf_METHOD;
	100	else
	101	CvFLAGS((CV*)sv) \|= CVf_METHOD;
	102	continue;
	103	}
	104	break;
	105	}
	106	break;
	107	}
	108	break;
	109	default:
0256094b	110	switch ((int)len) {
95f0a2f1	111	case 6:
8cad210e	112	switch (name[5]) {
	113	case 'd':
	114	if (memEQ(name, "share", 5)) {
13c1b207	115	if (negated)
	116	Perl_croak(aTHX_ "A variable may not be unshared");
	117	SvSHARE(sv);
	118	continue;
	119	}
	120	break;
8cad210e	121	case 'e':
8cad210e	122	if (memEQ(name, "uniqu", 5)) {
6e592b3a	123	if (isGV_with_GP(sv)) {
44f8325f	124	if (negated) {
95f0a2f1	125	GvUNIQUE_off(sv);
44f8325f	126	} else {
95f0a2f1	127	GvUNIQUE_on(sv);
44f8325f	128	}
95f0a2f1	129	}
95f0a2f1	130	/* Hope this came from toke.c if not a GV. */
0256094b	131	continue;
	132	}
	133	}
	134	}
09bef843	135	break;
	136	}
	137	/* anything recognized had a 'continue' above */
	138	*retlist++ = attr;
	139	nret++;
	140	}
	141
	142	return nret;
	143	}
	144
	145
09bef843	146
	147	/* package attributes; */
	148
	149	XS(XS_attributes_bootstrap)
	150	{
97aff369	151	dVAR;
09bef843	152	dXSARGS;
09bef843	153
592f5969	154	if( items > 1 )
afa74d42	155	croak_xs_usage(cv, "$module");
b7953727	156
09bef843	157	newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
	158	newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
	159	newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
	160	newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
	161
	162	XSRETURN(0);
	163	}
	164
	165	XS(XS_attributes__modify_attrs)
	166	{
97aff369	167	dVAR;
09bef843	168	dXSARGS;
	169	SV rv, sv;
	170
	171	if (items < 1) {
	172	usage:
afa74d42	173	croak_xs_usage(cv, "@attributes");
09bef843	174	}
	175
	176	rv = ST(0);
	177	if (!(SvOK(rv) && SvROK(rv)))
	178	goto usage;
	179	sv = SvRV(rv);
	180	if (items > 1)
acfe0abc	181	XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843	182
	183	XSRETURN(0);
	184	}
	185
	186	XS(XS_attributes__fetch_attrs)
	187	{
97aff369	188	dVAR;
09bef843	189	dXSARGS;
	190	SV rv, sv;
	191	cv_flags_t cvflags;
	192
	193	if (items != 1) {
	194	usage:
afa74d42	195	croak_xs_usage(cv, "$reference");
09bef843	196	}
	197
	198	rv = ST(0);
	199	SP -= items;
	200	if (!(SvOK(rv) && SvROK(rv)))
	201	goto usage;
	202	sv = SvRV(rv);
	203
	204	switch (SvTYPE(sv)) {
	205	case SVt_PVCV:
	206	cvflags = CvFLAGS((CV*)sv);
	207	if (cvflags & CVf_LOCKED)
84bafc02	208	XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
09bef843	209	#ifdef CVf_LVALUE
09bef843	210	if (cvflags & CVf_LVALUE)
84bafc02	211	XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
09bef843	212	#endif
09bef843	213	if (cvflags & CVf_METHOD)
84bafc02	214	XPUSHs(newSVpvs_flags("method", SVs_TEMP));
7fb37951	215	if (GvUNIQUE(CvGV((CV*)sv)))
84bafc02	216	XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
95f0a2f1	217	break;
95f0a2f1	218	case SVt_PVGV:
6e592b3a	219	if (isGV_with_GP(sv) && GvUNIQUE(sv))
84bafc02	220	XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
09bef843	221	break;
	222	default:
	223	break;
	224	}
	225
	226	PUTBACK;
	227	}
	228
	229	XS(XS_attributes__guess_stash)
	230	{
97aff369	231	dVAR;
09bef843	232	dXSARGS;
09bef843	233	SV rv, sv;
d277572a	234	dXSTARG;
09bef843	235
	236	if (items != 1) {
	237	usage:
afa74d42	238	croak_xs_usage(cv, "$reference");
09bef843	239	}
	240
	241	rv = ST(0);
	242	ST(0) = TARG;
	243	if (!(SvOK(rv) && SvROK(rv)))
	244	goto usage;
	245	sv = SvRV(rv);
	246
	247	if (SvOBJECT(sv))
7423f6db	248	sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
09bef843	249	#if 0 /* this was probably a bad idea */
	250	else if (SvPADMY(sv))
	251	sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
	252	#endif
	253	else {
5c284bb0	254	const HV *stash = NULL;
09bef843	255	switch (SvTYPE(sv)) {
09bef843	256	case SVt_PVCV:
6676db26	257	if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843	258	stash = GvSTASH(CvGV(sv));
6676db26	259	else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843	260	stash = CvSTASH(sv);
09bef843	261	break;
09bef843	262	case SVt_PVGV:
6e592b3a	263	if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH((GV*)sv))
09bef843	264	stash = GvESTASH((GV*)sv);
	265	break;
	266	default:
	267	break;
	268	}
	269	if (stash)
7423f6db	270	sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
09bef843	271	}
09bef843	272
09bef843	273	SvSETMAGIC(TARG);
09bef843	274	XSRETURN(1);
	275	}
	276
	277	XS(XS_attributes_reftype)
	278	{
97aff369	279	dVAR;
09bef843	280	dXSARGS;
09bef843	281	SV rv, sv;
d277572a	282	dXSTARG;
09bef843	283
	284	if (items != 1) {
	285	usage:
afa74d42	286	croak_xs_usage(cv, "$reference");
09bef843	287	}
	288
	289	rv = ST(0);
	290	ST(0) = TARG;
5b295bef	291	SvGETMAGIC(rv);
121e869f	292	if (!(SvOK(rv) && SvROK(rv)))
09bef843	293	goto usage;
	294	sv = SvRV(rv);
	295	sv_setpv(TARG, sv_reftype(sv, 0));
09bef843	296	SvSETMAGIC(TARG);
09bef843	297
	298	XSRETURN(1);
	299	}
	300
66610fdd	301	/*
	302	* Local variables:
	303	* c-indentation-style: bsd
	304	* c-basic-offset: 4
	305	* indent-tabs-mode: t
	306	* End:
	307	*
37442d52	308	* ex: set ts=8 sts=4 sw=4 noet:
37442d52	309	*/